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>
36 /* Without this, sprintf on Mac OS Classic will produce wrong
42 #if defined HAVE_SYS_RESOURCE_H
46 #include <sys/resource.h>
52 #include "intervals.h"
63 #define MAX_10_EXP DBL_MAX_10_EXP
65 #define MAX_10_EXP 310
73 extern char **environ
;
76 extern Lisp_Object make_time
P_ ((time_t));
77 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
78 const struct tm
*, int));
79 static int tm_diff
P_ ((struct tm
*, struct tm
*));
80 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
81 static void update_buffer_properties
P_ ((int, int));
82 static Lisp_Object region_limit
P_ ((int));
83 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
84 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
85 size_t, const struct tm
*, int));
86 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
87 void (*) (Lisp_Object
, int, int, int,
89 int, int, Lisp_Object
*));
90 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
91 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
92 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
95 extern char *index
P_ ((const char *, int));
98 Lisp_Object Vbuffer_access_fontify_functions
;
99 Lisp_Object Qbuffer_access_fontify_functions
;
100 Lisp_Object Vbuffer_access_fontified_property
;
102 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
104 /* Non-nil means don't stop at field boundary in text motion commands. */
106 Lisp_Object Vinhibit_field_text_motion
;
108 /* Some static data, and a function to initialize it for each run */
110 Lisp_Object Vsystem_name
;
111 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
112 Lisp_Object Vuser_full_name
; /* full name of current user */
113 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
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");
180 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
181 doc
: /* Convert arg CHAR to a string containing that character.
182 usage: (char-to-string CHAR) */)
184 Lisp_Object character
;
187 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
189 CHECK_NUMBER (character
);
191 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
192 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
193 : char_to_string (XFASTINT (character
), str
));
194 return make_string_from_bytes (str
, 1, len
);
197 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
198 doc
: /* Convert arg STRING to a character, the first character of that string.
199 A multibyte character is handled correctly. */)
201 register Lisp_Object string
;
203 register Lisp_Object val
;
204 CHECK_STRING (string
);
207 if (STRING_MULTIBYTE (string
))
208 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
210 XSETFASTINT (val
, SREF (string
, 0));
213 XSETFASTINT (val
, 0);
218 buildmark (charpos
, bytepos
)
219 int charpos
, bytepos
;
221 register Lisp_Object mark
;
222 mark
= Fmake_marker ();
223 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
227 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
228 doc
: /* Return value of point, as an integer.
229 Beginning of buffer is position (point-min). */)
233 XSETFASTINT (temp
, PT
);
237 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
238 doc
: /* Return value of point, as a marker object. */)
241 return buildmark (PT
, PT_BYTE
);
245 clip_to_bounds (lower
, num
, upper
)
246 int lower
, num
, upper
;
250 else if (num
> upper
)
256 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
257 doc
: /* Set point to POSITION, a number or marker.
258 Beginning of buffer is position (point-min), end is (point-max).
259 If the position is in the middle of a multibyte form,
260 the actual point is set at the head of the multibyte form
261 except in the case that `enable-multibyte-characters' is nil. */)
263 register Lisp_Object position
;
267 if (MARKERP (position
)
268 && current_buffer
== XMARKER (position
)->buffer
)
270 pos
= marker_position (position
);
272 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
274 SET_PT_BOTH (ZV
, ZV_BYTE
);
276 SET_PT_BOTH (pos
, marker_byte_position (position
));
281 CHECK_NUMBER_COERCE_MARKER (position
);
283 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
289 /* Return the start or end position of the region.
290 BEGINNINGP non-zero means return the start.
291 If there is no region active, signal an error. */
294 region_limit (beginningp
)
297 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
300 if (!NILP (Vtransient_mark_mode
)
301 && NILP (Vmark_even_if_inactive
)
302 && NILP (current_buffer
->mark_active
))
303 Fsignal (Qmark_inactive
, Qnil
);
305 m
= Fmarker_position (current_buffer
->mark
);
307 error ("The mark is not set now, so there is no region");
309 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
310 m
= make_number (PT
);
314 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
315 doc
: /* Return position of beginning of region, as an integer. */)
318 return region_limit (1);
321 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
322 doc
: /* Return position of end of region, as an integer. */)
325 return region_limit (0);
328 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
329 doc
: /* Return this buffer's mark, as a marker object.
330 Watch out! Moving this marker changes the mark position.
331 If you set the marker not to point anywhere, the buffer will have no mark. */)
334 return current_buffer
->mark
;
338 /* Find all the overlays in the current buffer that touch position POS.
339 Return the number found, and store them in a vector in VEC
343 overlays_around (pos
, vec
, len
)
348 Lisp_Object overlay
, start
, end
;
349 struct Lisp_Overlay
*tail
;
350 int startpos
, endpos
;
353 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
355 XSETMISC (overlay
, tail
);
357 end
= OVERLAY_END (overlay
);
358 endpos
= OVERLAY_POSITION (end
);
361 start
= OVERLAY_START (overlay
);
362 startpos
= OVERLAY_POSITION (start
);
367 /* Keep counting overlays even if we can't return them all. */
372 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
374 XSETMISC (overlay
, tail
);
376 start
= OVERLAY_START (overlay
);
377 startpos
= OVERLAY_POSITION (start
);
380 end
= OVERLAY_END (overlay
);
381 endpos
= OVERLAY_POSITION (end
);
393 /* Return the value of property PROP, in OBJECT at POSITION.
394 It's the value of PROP that a char inserted at POSITION would get.
395 OBJECT is optional and defaults to the current buffer.
396 If OBJECT is a buffer, then overlay properties are considered as well as
398 If OBJECT is a window, then that window's buffer is used, but
399 window-specific overlays are considered only if they are associated
402 get_pos_property (position
, prop
, object
)
403 Lisp_Object position
, object
;
404 register Lisp_Object prop
;
406 CHECK_NUMBER_COERCE_MARKER (position
);
409 XSETBUFFER (object
, current_buffer
);
410 else if (WINDOWP (object
))
411 object
= XWINDOW (object
)->buffer
;
413 if (!BUFFERP (object
))
414 /* pos-property only makes sense in buffers right now, since strings
415 have no overlays and no notion of insertion for which stickiness
417 return Fget_text_property (position
, prop
, object
);
420 int posn
= XINT (position
);
422 Lisp_Object
*overlay_vec
, tem
;
423 struct buffer
*obuf
= current_buffer
;
425 set_buffer_temp (XBUFFER (object
));
427 /* First try with room for 40 overlays. */
429 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
430 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
432 /* If there are more than 40,
433 make enough space for all, and try again. */
436 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
437 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
439 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
441 set_buffer_temp (obuf
);
443 /* Now check the overlays in order of decreasing priority. */
444 while (--noverlays
>= 0)
446 Lisp_Object ol
= overlay_vec
[noverlays
];
447 tem
= Foverlay_get (ol
, prop
);
450 /* Check the overlay is indeed active at point. */
451 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
452 if ((OVERLAY_POSITION (start
) == posn
453 && XMARKER (start
)->insertion_type
== 1)
454 || (OVERLAY_POSITION (finish
) == posn
455 && XMARKER (finish
)->insertion_type
== 0))
456 ; /* The overlay will not cover a char inserted at point. */
464 { /* Now check the text-properties. */
465 int stickiness
= text_property_stickiness (prop
, position
, object
);
467 return Fget_text_property (position
, prop
, object
);
468 else if (stickiness
< 0
469 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
470 return Fget_text_property (make_number (XINT (position
) - 1),
478 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
479 the value of point is used instead. If BEG or END null,
480 means don't store the beginning or end of the field.
482 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
483 results; they do not effect boundary behavior.
485 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
486 position of a field, then the beginning of the previous field is
487 returned instead of the beginning of POS's field (since the end of a
488 field is actually also the beginning of the next input field, this
489 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
490 true case, if two fields are separated by a field with the special
491 value `boundary', and POS lies within it, then the two separated
492 fields are considered to be adjacent, and POS between them, when
493 finding the beginning and ending of the "merged" field.
495 Either BEG or END may be 0, in which case the corresponding value
499 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
501 Lisp_Object merge_at_boundary
;
502 Lisp_Object beg_limit
, end_limit
;
505 /* Fields right before and after the point. */
506 Lisp_Object before_field
, after_field
;
507 /* 1 if POS counts as the start of a field. */
508 int at_field_start
= 0;
509 /* 1 if POS counts as the end of a field. */
510 int at_field_end
= 0;
513 XSETFASTINT (pos
, PT
);
515 CHECK_NUMBER_COERCE_MARKER (pos
);
518 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
520 = (XFASTINT (pos
) > BEGV
521 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
525 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
526 and POS is at beginning of a field, which can also be interpreted
527 as the end of the previous field. Note that the case where if
528 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
529 more natural one; then we avoid treating the beginning of a field
531 if (NILP (merge_at_boundary
))
533 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
534 if (!EQ (field
, after_field
))
536 if (!EQ (field
, before_field
))
538 if (NILP (field
) && at_field_start
&& at_field_end
)
539 /* If an inserted char would have a nil field while the surrounding
540 text is non-nil, we're probably not looking at a
541 zero-length field, but instead at a non-nil field that's
542 not intended for editing (such as comint's prompts). */
543 at_field_end
= at_field_start
= 0;
546 /* Note about special `boundary' fields:
548 Consider the case where the point (`.') is between the fields `x' and `y':
552 In this situation, if merge_at_boundary is true, we consider the
553 `x' and `y' fields as forming one big merged field, and so the end
554 of the field is the end of `y'.
556 However, if `x' and `y' are separated by a special `boundary' field
557 (a field with a `field' char-property of 'boundary), then we ignore
558 this special field when merging adjacent fields. Here's the same
559 situation, but with a `boundary' field between the `x' and `y' fields:
563 Here, if point is at the end of `x', the beginning of `y', or
564 anywhere in-between (within the `boundary' field), we merge all
565 three fields and consider the beginning as being the beginning of
566 the `x' field, and the end as being the end of the `y' field. */
571 /* POS is at the edge of a field, and we should consider it as
572 the beginning of the following field. */
573 *beg
= XFASTINT (pos
);
575 /* Find the previous field boundary. */
578 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
579 /* Skip a `boundary' field. */
580 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
583 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
585 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
592 /* POS is at the edge of a field, and we should consider it as
593 the end of the previous field. */
594 *end
= XFASTINT (pos
);
596 /* Find the next field boundary. */
598 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
599 /* Skip a `boundary' field. */
600 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
603 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
605 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
611 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
612 doc
: /* Delete the field surrounding POS.
613 A field is a region of text with the same `field' property.
614 If POS is nil, the value of point is used for POS. */)
619 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
621 del_range (beg
, end
);
625 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
626 doc
: /* Return the contents of the field surrounding POS as a string.
627 A field is a region of text with the same `field' property.
628 If POS is nil, the value of point is used for POS. */)
633 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
634 return make_buffer_string (beg
, end
, 1);
637 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
638 doc
: /* Return the contents of the field around POS, without text-properties.
639 A field is a region of text with the same `field' property.
640 If POS is nil, the value of point is used for POS. */)
645 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
646 return make_buffer_string (beg
, end
, 0);
649 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
650 doc
: /* Return the beginning of the field surrounding POS.
651 A field is a region of text with the same `field' property.
652 If POS is nil, the value of point is used for POS.
653 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
654 field, then the beginning of the *previous* field is returned.
655 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
656 is before LIMIT, then LIMIT will be returned instead. */)
657 (pos
, escape_from_edge
, limit
)
658 Lisp_Object pos
, escape_from_edge
, limit
;
661 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
662 return make_number (beg
);
665 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
666 doc
: /* Return the end of the field surrounding POS.
667 A field is a region of text with the same `field' property.
668 If POS is nil, the value of point is used for POS.
669 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
670 then the end of the *following* field is returned.
671 If LIMIT is non-nil, it is a buffer position; if the end of the field
672 is after LIMIT, then LIMIT will be returned instead. */)
673 (pos
, escape_from_edge
, limit
)
674 Lisp_Object pos
, escape_from_edge
, limit
;
677 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
678 return make_number (end
);
681 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
682 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
684 A field is a region of text with the same `field' property.
685 If NEW-POS is nil, then the current point is used instead, and set to the
686 constrained position if that is different.
688 If OLD-POS is at the boundary of two fields, then the allowable
689 positions for NEW-POS depends on the value of the optional argument
690 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
691 constrained to the field that has the same `field' char-property
692 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
693 is non-nil, NEW-POS is constrained to the union of the two adjacent
694 fields. Additionally, if two fields are separated by another field with
695 the special value `boundary', then any point within this special field is
696 also considered to be `on the boundary'.
698 If the optional argument ONLY-IN-LINE is non-nil and constraining
699 NEW-POS would move it to a different line, NEW-POS is returned
700 unconstrained. This useful for commands that move by line, like
701 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
702 only in the case where they can still move to the right line.
704 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
705 a non-nil property of that name, then any field boundaries are ignored.
707 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
708 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
709 Lisp_Object new_pos
, old_pos
;
710 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
712 /* If non-zero, then the original point, before re-positioning. */
716 /* Use the current point, and afterwards, set it. */
719 XSETFASTINT (new_pos
, PT
);
722 if (NILP (Vinhibit_field_text_motion
)
723 && !EQ (new_pos
, old_pos
)
724 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
725 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
726 && (NILP (inhibit_capture_property
)
727 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
728 /* NEW_POS is not within the same field as OLD_POS; try to
729 move NEW_POS so that it is. */
732 Lisp_Object field_bound
;
734 CHECK_NUMBER_COERCE_MARKER (new_pos
);
735 CHECK_NUMBER_COERCE_MARKER (old_pos
);
737 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
740 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
742 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
744 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
745 other side of NEW_POS, which would mean that NEW_POS is
746 already acceptable, and it's not necessary to constrain it
748 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
749 /* NEW_POS should be constrained, but only if either
750 ONLY_IN_LINE is nil (in which case any constraint is OK),
751 or NEW_POS and FIELD_BOUND are on the same line (in which
752 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
753 && (NILP (only_in_line
)
754 /* This is the ONLY_IN_LINE case, check that NEW_POS and
755 FIELD_BOUND are on the same line by seeing whether
756 there's an intervening newline or not. */
757 || (scan_buffer ('\n',
758 XFASTINT (new_pos
), XFASTINT (field_bound
),
759 fwd
? -1 : 1, &shortage
, 1),
761 /* Constrain NEW_POS to FIELD_BOUND. */
762 new_pos
= field_bound
;
764 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
765 /* The NEW_POS argument was originally nil, so automatically set PT. */
766 SET_PT (XFASTINT (new_pos
));
773 DEFUN ("line-beginning-position",
774 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
775 doc
: /* Return the character position of the first character on the current line.
776 With argument N not nil or 1, move forward N - 1 lines first.
777 If scan reaches end of buffer, return that position.
779 The scan does not cross a field boundary unless doing so would move
780 beyond there to a different line; if N is nil or 1, and scan starts at a
781 field boundary, the scan stops as soon as it starts. To ignore field
782 boundaries bind `inhibit-field-text-motion' to t.
784 This function does not move point. */)
788 int orig
, orig_byte
, end
;
797 Fforward_line (make_number (XINT (n
) - 1));
800 SET_PT_BOTH (orig
, orig_byte
);
802 /* Return END constrained to the current input field. */
803 return Fconstrain_to_field (make_number (end
), make_number (orig
),
804 XINT (n
) != 1 ? Qt
: Qnil
,
808 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
809 doc
: /* Return the character position of the last character on the current line.
810 With argument N not nil or 1, move forward N - 1 lines first.
811 If scan reaches end of buffer, return that position.
813 The scan does not cross a field boundary unless doing so would move
814 beyond there to a different line; if N is nil or 1, and scan starts at a
815 field boundary, the scan stops as soon as it starts. To ignore field
816 boundaries bind `inhibit-field-text-motion' to t.
818 This function does not move point. */)
830 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
832 /* Return END_POS constrained to the current input field. */
833 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
839 save_excursion_save ()
841 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
844 return Fcons (Fpoint_marker (),
845 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
846 Fcons (visible
? Qt
: Qnil
,
847 Fcons (current_buffer
->mark_active
,
852 save_excursion_restore (info
)
855 Lisp_Object tem
, tem1
, omark
, nmark
;
856 struct gcpro gcpro1
, gcpro2
, gcpro3
;
859 tem
= Fmarker_buffer (XCAR (info
));
860 /* If buffer being returned to is now deleted, avoid error */
861 /* Otherwise could get error here while unwinding to top level
863 /* In that case, Fmarker_buffer returns nil now. */
867 omark
= nmark
= Qnil
;
868 GCPRO3 (info
, omark
, nmark
);
875 unchain_marker (XMARKER (tem
));
880 omark
= Fmarker_position (current_buffer
->mark
);
881 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
882 nmark
= Fmarker_position (tem
);
883 unchain_marker (XMARKER (tem
));
887 visible_p
= !NILP (XCAR (info
));
889 #if 0 /* We used to make the current buffer visible in the selected window
890 if that was true previously. That avoids some anomalies.
891 But it creates others, and it wasn't documented, and it is simpler
892 and cleaner never to alter the window/buffer connections. */
895 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
896 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
902 tem1
= current_buffer
->mark_active
;
903 current_buffer
->mark_active
= tem
;
905 if (!NILP (Vrun_hooks
))
907 /* If mark is active now, and either was not active
908 or was at a different place, run the activate hook. */
909 if (! NILP (current_buffer
->mark_active
))
911 if (! EQ (omark
, nmark
))
912 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
914 /* If mark has ceased to be active, run deactivate hook. */
915 else if (! NILP (tem1
))
916 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
919 /* If buffer was visible in a window, and a different window was
920 selected, and the old selected window is still showing this
921 buffer, restore point in that window. */
924 && !EQ (tem
, selected_window
)
925 && (tem1
= XWINDOW (tem
)->buffer
,
926 (/* Window is live... */
928 /* ...and it shows the current buffer. */
929 && XBUFFER (tem1
) == current_buffer
)))
930 Fset_window_point (tem
, make_number (PT
));
936 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
937 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
938 Executes BODY just like `progn'.
939 The values of point, mark and the current buffer are restored
940 even in case of abnormal exit (throw or error).
941 The state of activation of the mark is also restored.
943 This construct does not save `deactivate-mark', and therefore
944 functions that change the buffer will still cause deactivation
945 of the mark at the end of the command. To prevent that, bind
946 `deactivate-mark' with `let'.
948 usage: (save-excursion &rest BODY) */)
952 register Lisp_Object val
;
953 int count
= SPECPDL_INDEX ();
955 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
958 return unbind_to (count
, val
);
961 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
962 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
963 Executes BODY just like `progn'.
964 usage: (save-current-buffer &rest BODY) */)
969 int count
= SPECPDL_INDEX ();
971 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
974 return unbind_to (count
, val
);
977 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
978 doc
: /* Return the number of characters in the current buffer.
979 If BUFFER, return the number of characters in that buffer instead. */)
984 return make_number (Z
- BEG
);
987 CHECK_BUFFER (buffer
);
988 return make_number (BUF_Z (XBUFFER (buffer
))
989 - BUF_BEG (XBUFFER (buffer
)));
993 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
994 doc
: /* Return the minimum permissible value of point in the current buffer.
995 This is 1, unless narrowing (a buffer restriction) is in effect. */)
999 XSETFASTINT (temp
, BEGV
);
1003 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1004 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1005 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1008 return buildmark (BEGV
, BEGV_BYTE
);
1011 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1012 doc
: /* Return the maximum permissible value of point in the current buffer.
1013 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1014 is in effect, in which case it is less. */)
1018 XSETFASTINT (temp
, ZV
);
1022 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1023 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1024 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1025 is in effect, in which case it is less. */)
1028 return buildmark (ZV
, ZV_BYTE
);
1031 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1032 doc
: /* Return the position of the gap, in the current buffer.
1033 See also `gap-size'. */)
1037 XSETFASTINT (temp
, GPT
);
1041 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1042 doc
: /* Return the size of the current buffer's gap.
1043 See also `gap-position'. */)
1047 XSETFASTINT (temp
, GAP_SIZE
);
1051 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1052 doc
: /* Return the byte position for character position POSITION.
1053 If POSITION is out of range, the value is nil. */)
1055 Lisp_Object position
;
1057 CHECK_NUMBER_COERCE_MARKER (position
);
1058 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1060 return make_number (CHAR_TO_BYTE (XINT (position
)));
1063 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1064 doc
: /* Return the character position for byte position BYTEPOS.
1065 If BYTEPOS is out of range, the value is nil. */)
1067 Lisp_Object bytepos
;
1069 CHECK_NUMBER (bytepos
);
1070 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1072 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1075 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1076 doc
: /* Return the character following point, as a number.
1077 At the end of the buffer or accessible region, return 0. */)
1082 XSETFASTINT (temp
, 0);
1084 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1088 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1089 doc
: /* Return the character preceding point, as a number.
1090 At the beginning of the buffer or accessible region, return 0. */)
1095 XSETFASTINT (temp
, 0);
1096 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1100 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1103 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1107 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1108 doc
: /* Return t if point is at the beginning of the buffer.
1109 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1117 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1118 doc
: /* Return t if point is at the end of the buffer.
1119 If the buffer is narrowed, this means the end of the narrowed part. */)
1127 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1128 doc
: /* Return t if point is at the beginning of a line. */)
1131 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1136 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1137 doc
: /* Return t if point is at the end of a line.
1138 `End of a line' includes point being at the end of the buffer. */)
1141 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1146 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1147 doc
: /* Return character in current buffer at position POS.
1148 POS is an integer or a marker and defaults to point.
1149 If POS is out of range, the value is nil. */)
1153 register int pos_byte
;
1158 XSETFASTINT (pos
, PT
);
1163 pos_byte
= marker_byte_position (pos
);
1164 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1169 CHECK_NUMBER_COERCE_MARKER (pos
);
1170 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1173 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1176 return make_number (FETCH_CHAR (pos_byte
));
1179 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1180 doc
: /* Return character in current buffer preceding position POS.
1181 POS is an integer or a marker and defaults to point.
1182 If POS is out of range, the value is nil. */)
1186 register Lisp_Object val
;
1187 register int pos_byte
;
1192 XSETFASTINT (pos
, PT
);
1197 pos_byte
= marker_byte_position (pos
);
1199 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1204 CHECK_NUMBER_COERCE_MARKER (pos
);
1206 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1209 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1212 if (!NILP (current_buffer
->enable_multibyte_characters
))
1215 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1220 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1225 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1226 doc
: /* Return the name under which the user logged in, as a string.
1227 This is based on the effective uid, not the real uid.
1228 Also, if the environment variables LOGNAME or USER are set,
1229 that determines the value of this function.
1231 If optional argument UID is an integer, return the login name of the user
1232 with that uid, or nil if there is no such user. */)
1238 /* Set up the user name info if we didn't do it before.
1239 (That can happen if Emacs is dumpable
1240 but you decide to run `temacs -l loadup' and not dump. */
1241 if (INTEGERP (Vuser_login_name
))
1245 return Vuser_login_name
;
1248 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1249 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1252 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1254 doc
: /* Return the name of the user's real uid, as a string.
1255 This ignores the environment variables LOGNAME and USER, so it differs from
1256 `user-login-name' when running under `su'. */)
1259 /* Set up the user name info if we didn't do it before.
1260 (That can happen if Emacs is dumpable
1261 but you decide to run `temacs -l loadup' and not dump. */
1262 if (INTEGERP (Vuser_login_name
))
1264 return Vuser_real_login_name
;
1267 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1268 doc
: /* Return the effective uid of Emacs.
1269 Value is an integer or float, depending on the value. */)
1272 return make_fixnum_or_float (geteuid ());
1275 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1276 doc
: /* Return the real uid of Emacs.
1277 Value is an integer or float, depending on the value. */)
1280 return make_fixnum_or_float (getuid ());
1283 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1284 doc
: /* Return the full name of the user logged in, as a string.
1285 If the full name corresponding to Emacs's userid is not known,
1288 If optional argument UID is an integer or float, return the full name
1289 of the user with that uid, or nil if there is no such user.
1290 If UID is a string, return the full name of the user with that login
1291 name, or nil if there is no such user. */)
1296 register unsigned char *p
, *q
;
1300 return Vuser_full_name
;
1301 else if (NUMBERP (uid
))
1302 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1303 else if (STRINGP (uid
))
1304 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1306 error ("Invalid UID specification");
1311 p
= (unsigned char *) USER_FULL_NAME
;
1312 /* Chop off everything after the first comma. */
1313 q
= (unsigned char *) index (p
, ',');
1314 full
= make_string (p
, q
? q
- p
: strlen (p
));
1316 #ifdef AMPERSAND_FULL_NAME
1318 q
= (unsigned char *) index (p
, '&');
1319 /* Substitute the login name for the &, upcasing the first character. */
1322 register unsigned char *r
;
1325 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1326 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1327 bcopy (p
, r
, q
- p
);
1329 strcat (r
, SDATA (login
));
1330 r
[q
- p
] = UPCASE (r
[q
- p
]);
1332 full
= build_string (r
);
1334 #endif /* AMPERSAND_FULL_NAME */
1339 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1340 doc
: /* Return the name of the machine you are running on, as a string. */)
1343 return Vsystem_name
;
1346 /* For the benefit of callers who don't want to include lisp.h */
1351 if (STRINGP (Vsystem_name
))
1352 return (char *) SDATA (Vsystem_name
);
1357 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1358 doc
: /* Return the process ID of Emacs, as an integer. */)
1361 return make_number (getpid ());
1364 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1365 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1366 The time is returned as a list of three integers. The first has the
1367 most significant 16 bits of the seconds, while the second has the
1368 least significant 16 bits. The third integer gives the microsecond
1371 The microsecond count is zero on systems that do not provide
1372 resolution finer than a second. */)
1376 Lisp_Object result
[3];
1379 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1380 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1381 XSETINT (result
[2], EMACS_USECS (t
));
1383 return Flist (3, result
);
1386 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1388 doc
: /* Return the current run time used by Emacs.
1389 The time is returned as a list of three integers. The first has the
1390 most significant 16 bits of the seconds, while the second has the
1391 least significant 16 bits. The third integer gives the microsecond
1394 On systems that can't determine the run time, get-internal-run-time
1395 does the same thing as current-time. The microsecond count is zero on
1396 systems that do not provide resolution finer than a second. */)
1399 #ifdef HAVE_GETRUSAGE
1400 struct rusage usage
;
1401 Lisp_Object result
[3];
1404 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1405 /* This shouldn't happen. What action is appropriate? */
1406 Fsignal (Qerror
, Qnil
);
1408 /* Sum up user time and system time. */
1409 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1410 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1411 if (usecs
>= 1000000)
1417 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1418 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1419 XSETINT (result
[2], usecs
);
1421 return Flist (3, result
);
1423 return Fcurrent_time ();
1429 lisp_time_argument (specified_time
, result
, usec
)
1430 Lisp_Object specified_time
;
1434 if (NILP (specified_time
))
1441 *usec
= EMACS_USECS (t
);
1442 *result
= EMACS_SECS (t
);
1446 return time (result
) != -1;
1450 Lisp_Object high
, low
;
1451 high
= Fcar (specified_time
);
1452 CHECK_NUMBER (high
);
1453 low
= Fcdr (specified_time
);
1458 Lisp_Object usec_l
= Fcdr (low
);
1460 usec_l
= Fcar (usec_l
);
1465 CHECK_NUMBER (usec_l
);
1466 *usec
= XINT (usec_l
);
1474 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1475 return *result
>> 16 == XINT (high
);
1479 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1480 doc
: /* Return the current time, as a float number of seconds since the epoch.
1481 If SPECIFIED-TIME is given, it is the time to convert to float
1482 instead of the current time. The argument should have the form
1483 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1484 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1485 have the form (HIGH . LOW), but this is considered obsolete.
1487 WARNING: Since the result is floating point, it may not be exact.
1488 Do not use this function if precise time stamps are required. */)
1490 Lisp_Object specified_time
;
1495 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1496 error ("Invalid time specification");
1498 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1501 /* Write information into buffer S of size MAXSIZE, according to the
1502 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1503 Default to Universal Time if UT is nonzero, local time otherwise.
1504 Return the number of bytes written, not including the terminating
1505 '\0'. If S is NULL, nothing will be written anywhere; so to
1506 determine how many bytes would be written, use NULL for S and
1507 ((size_t) -1) for MAXSIZE.
1509 This function behaves like emacs_strftimeu, except it allows null
1512 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1517 const struct tm
*tp
;
1522 /* Loop through all the null-terminated strings in the format
1523 argument. Normally there's just one null-terminated string, but
1524 there can be arbitrarily many, concatenated together, if the
1525 format contains '\0' bytes. emacs_strftimeu stops at the first
1526 '\0' byte so we must invoke it separately for each such string. */
1535 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1539 if (result
== 0 && s
[0] != '\0')
1544 maxsize
-= result
+ 1;
1546 len
= strlen (format
);
1547 if (len
== format_len
)
1551 format_len
-= len
+ 1;
1555 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1556 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1557 TIME is specified as (HIGH LOW . IGNORED), as returned by
1558 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1559 is also still accepted.
1560 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1561 as Universal Time; nil means describe TIME in the local time zone.
1562 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1563 by text that describes the specified date and time in TIME:
1565 %Y is the year, %y within the century, %C the century.
1566 %G is the year corresponding to the ISO week, %g within the century.
1567 %m is the numeric month.
1568 %b and %h are the locale's abbreviated month name, %B the full name.
1569 %d is the day of the month, zero-padded, %e is blank-padded.
1570 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1571 %a is the locale's abbreviated name of the day of week, %A the full name.
1572 %U is the week number starting on Sunday, %W starting on Monday,
1573 %V according to ISO 8601.
1574 %j is the day of the year.
1576 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1577 only blank-padded, %l is like %I blank-padded.
1578 %p is the locale's equivalent of either AM or PM.
1581 %Z is the time zone name, %z is the numeric form.
1582 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1584 %c is the locale's date and time format.
1585 %x is the locale's "preferred" date format.
1586 %D is like "%m/%d/%y".
1588 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1589 %X is the locale's "preferred" time format.
1591 Finally, %n is a newline, %t is a tab, %% is a literal %.
1593 Certain flags and modifiers are available with some format controls.
1594 The flags are `_', `-', `^' and `#'. For certain characters X,
1595 %_X is like %X, but padded with blanks; %-X is like %X,
1596 but without padding. %^X is like %X, but with all textual
1597 characters up-cased; %#X is like %X, but with letter-case of
1598 all textual characters reversed.
1599 %NX (where N stands for an integer) is like %X,
1600 but takes up at least N (a number) positions.
1601 The modifiers are `E' and `O'. For certain characters X,
1602 %EX is a locale's alternative version of %X;
1603 %OX is like %X, but uses the locale's number symbols.
1605 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1606 (format_string
, time
, universal
)
1607 Lisp_Object format_string
, time
, universal
;
1612 int ut
= ! NILP (universal
);
1614 CHECK_STRING (format_string
);
1616 if (! lisp_time_argument (time
, &value
, NULL
))
1617 error ("Invalid time specification");
1619 format_string
= code_convert_string_norecord (format_string
,
1620 Vlocale_coding_system
, 1);
1622 /* This is probably enough. */
1623 size
= SBYTES (format_string
) * 6 + 50;
1625 tm
= ut
? gmtime (&value
) : localtime (&value
);
1627 error ("Specified time is not representable");
1629 synchronize_system_time_locale ();
1633 char *buf
= (char *) alloca (size
+ 1);
1637 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1638 SBYTES (format_string
),
1640 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1641 return code_convert_string_norecord (make_string (buf
, result
),
1642 Vlocale_coding_system
, 0);
1644 /* If buffer was too small, make it bigger and try again. */
1645 result
= emacs_memftimeu (NULL
, (size_t) -1,
1646 SDATA (format_string
),
1647 SBYTES (format_string
),
1653 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1654 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1655 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1656 as from `current-time' and `file-attributes', or `nil' to use the
1657 current time. The obsolete form (HIGH . LOW) is also still accepted.
1658 The list has the following nine members: SEC is an integer between 0
1659 and 60; SEC is 60 for a leap second, which only some operating systems
1660 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1661 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1662 integer between 1 and 12. YEAR is an integer indicating the
1663 four-digit year. DOW is the day of week, an integer between 0 and 6,
1664 where 0 is Sunday. DST is t if daylight savings time is effect,
1665 otherwise nil. ZONE is an integer indicating the number of seconds
1666 east of Greenwich. (Note that Common Lisp has different meanings for
1669 Lisp_Object specified_time
;
1673 struct tm
*decoded_time
;
1674 Lisp_Object list_args
[9];
1676 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1677 error ("Invalid time specification");
1679 decoded_time
= localtime (&time_spec
);
1681 error ("Specified time is not representable");
1682 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1683 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1684 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1685 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1686 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1687 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1688 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1689 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1691 /* Make a copy, in case gmtime modifies the struct. */
1692 save_tm
= *decoded_time
;
1693 decoded_time
= gmtime (&time_spec
);
1694 if (decoded_time
== 0)
1695 list_args
[8] = Qnil
;
1697 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1698 return Flist (9, list_args
);
1701 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1702 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1703 This is the reverse operation of `decode-time', which see.
1704 ZONE defaults to the current time zone rule. This can
1705 be a string or t (as from `set-time-zone-rule'), or it can be a list
1706 \(as from `current-time-zone') or an integer (as from `decode-time')
1707 applied without consideration for daylight savings time.
1709 You can pass more than 7 arguments; then the first six arguments
1710 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1711 The intervening arguments are ignored.
1712 This feature lets (apply 'encode-time (decode-time ...)) work.
1714 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1715 for example, a DAY of 0 means the day preceding the given month.
1716 Year numbers less than 100 are treated just like other year numbers.
1717 If you want them to stand for years in this century, you must do that yourself.
1719 Years before 1970 are not guaranteed to work. On some systems,
1720 year values as low as 1901 do work.
1722 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1725 register Lisp_Object
*args
;
1729 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1731 CHECK_NUMBER (args
[0]); /* second */
1732 CHECK_NUMBER (args
[1]); /* minute */
1733 CHECK_NUMBER (args
[2]); /* hour */
1734 CHECK_NUMBER (args
[3]); /* day */
1735 CHECK_NUMBER (args
[4]); /* month */
1736 CHECK_NUMBER (args
[5]); /* year */
1738 tm
.tm_sec
= XINT (args
[0]);
1739 tm
.tm_min
= XINT (args
[1]);
1740 tm
.tm_hour
= XINT (args
[2]);
1741 tm
.tm_mday
= XINT (args
[3]);
1742 tm
.tm_mon
= XINT (args
[4]) - 1;
1743 tm
.tm_year
= XINT (args
[5]) - 1900;
1749 time
= mktime (&tm
);
1754 char **oldenv
= environ
, **newenv
;
1758 else if (STRINGP (zone
))
1759 tzstring
= (char *) SDATA (zone
);
1760 else if (INTEGERP (zone
))
1762 int abszone
= abs (XINT (zone
));
1763 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1764 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1768 error ("Invalid time zone specification");
1770 /* Set TZ before calling mktime; merely adjusting mktime's returned
1771 value doesn't suffice, since that would mishandle leap seconds. */
1772 set_time_zone_rule (tzstring
);
1774 time
= mktime (&tm
);
1776 /* Restore TZ to previous value. */
1780 #ifdef LOCALTIME_CACHE
1785 if (time
== (time_t) -1)
1786 error ("Specified time is not representable");
1788 return make_time (time
);
1791 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1792 doc
: /* Return the current time, as a human-readable string.
1793 Programs can use this function to decode a time,
1794 since the number of columns in each field is fixed.
1795 The format is `Sun Sep 16 01:03:52 1973'.
1796 However, see also the functions `decode-time' and `format-time-string'
1797 which provide a much more powerful and general facility.
1799 If SPECIFIED-TIME is given, it is a time to format instead of the
1800 current time. The argument should have the form (HIGH LOW . IGNORED).
1801 Thus, you can use times obtained from `current-time' and from
1802 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1803 but this is considered obsolete. */)
1805 Lisp_Object specified_time
;
1811 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1813 tem
= (char *) ctime (&value
);
1815 strncpy (buf
, tem
, 24);
1818 return build_string (buf
);
1821 #define TM_YEAR_BASE 1900
1823 /* Yield A - B, measured in seconds.
1824 This function is copied from the GNU C Library. */
1829 /* Compute intervening leap days correctly even if year is negative.
1830 Take care to avoid int overflow in leap day calculations,
1831 but it's OK to assume that A and B are close to each other. */
1832 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1833 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1834 int a100
= a4
/ 25 - (a4
% 25 < 0);
1835 int b100
= b4
/ 25 - (b4
% 25 < 0);
1836 int a400
= a100
>> 2;
1837 int b400
= b100
>> 2;
1838 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1839 int years
= a
->tm_year
- b
->tm_year
;
1840 int days
= (365 * years
+ intervening_leap_days
1841 + (a
->tm_yday
- b
->tm_yday
));
1842 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1843 + (a
->tm_min
- b
->tm_min
))
1844 + (a
->tm_sec
- b
->tm_sec
));
1847 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1848 doc
: /* Return the offset and name for the local time zone.
1849 This returns a list of the form (OFFSET NAME).
1850 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1851 A negative value means west of Greenwich.
1852 NAME is a string giving the name of the time zone.
1853 If SPECIFIED-TIME is given, the time zone offset is determined from it
1854 instead of using the current time. The argument should have the form
1855 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1856 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1857 have the form (HIGH . LOW), but this is considered obsolete.
1859 Some operating systems cannot provide all this information to Emacs;
1860 in this case, `current-time-zone' returns a list containing nil for
1861 the data it can't find. */)
1863 Lisp_Object specified_time
;
1869 if (lisp_time_argument (specified_time
, &value
, NULL
)
1870 && (t
= gmtime (&value
)) != 0
1871 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1873 int offset
= tm_diff (t
, &gmt
);
1878 s
= (char *)t
->tm_zone
;
1879 #else /* not HAVE_TM_ZONE */
1881 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1882 s
= tzname
[t
->tm_isdst
];
1884 #endif /* not HAVE_TM_ZONE */
1886 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1889 /* On Japanese w32, we can get a Japanese string as time
1890 zone name. Don't accept that. */
1892 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1901 /* No local time zone name is available; use "+-NNNN" instead. */
1902 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1903 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1906 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1909 return Fmake_list (make_number (2), Qnil
);
1912 /* This holds the value of `environ' produced by the previous
1913 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1914 has never been called. */
1915 static char **environbuf
;
1917 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1918 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1919 If TZ is nil, use implementation-defined default time zone information.
1920 If TZ is t, use Universal Time. */)
1928 else if (EQ (tz
, Qt
))
1933 tzstring
= (char *) SDATA (tz
);
1936 set_time_zone_rule (tzstring
);
1939 environbuf
= environ
;
1944 #ifdef LOCALTIME_CACHE
1946 /* These two values are known to load tz files in buggy implementations,
1947 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1948 Their values shouldn't matter in non-buggy implementations.
1949 We don't use string literals for these strings,
1950 since if a string in the environment is in readonly
1951 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1952 See Sun bugs 1113095 and 1114114, ``Timezone routines
1953 improperly modify environment''. */
1955 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1956 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1960 /* Set the local time zone rule to TZSTRING.
1961 This allocates memory into `environ', which it is the caller's
1962 responsibility to free. */
1965 set_time_zone_rule (tzstring
)
1969 char **from
, **to
, **newenv
;
1971 /* Make the ENVIRON vector longer with room for TZSTRING. */
1972 for (from
= environ
; *from
; from
++)
1974 envptrs
= from
- environ
+ 2;
1975 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1976 + (tzstring
? strlen (tzstring
) + 4 : 0));
1978 /* Add TZSTRING to the end of environ, as a value for TZ. */
1981 char *t
= (char *) (to
+ envptrs
);
1983 strcat (t
, tzstring
);
1987 /* Copy the old environ vector elements into NEWENV,
1988 but don't copy the TZ variable.
1989 So we have only one definition of TZ, which came from TZSTRING. */
1990 for (from
= environ
; *from
; from
++)
1991 if (strncmp (*from
, "TZ=", 3) != 0)
1997 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1998 the TZ variable is stored. If we do not have a TZSTRING,
1999 TO points to the vector slot which has the terminating null. */
2001 #ifdef LOCALTIME_CACHE
2003 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2004 "US/Pacific" that loads a tz file, then changes to a value like
2005 "XXX0" that does not load a tz file, and then changes back to
2006 its original value, the last change is (incorrectly) ignored.
2007 Also, if TZ changes twice in succession to values that do
2008 not load a tz file, tzset can dump core (see Sun bug#1225179).
2009 The following code works around these bugs. */
2013 /* Temporarily set TZ to a value that loads a tz file
2014 and that differs from tzstring. */
2016 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2017 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2023 /* The implied tzstring is unknown, so temporarily set TZ to
2024 two different values that each load a tz file. */
2025 *to
= set_time_zone_rule_tz1
;
2028 *to
= set_time_zone_rule_tz2
;
2033 /* Now TZ has the desired value, and tzset can be invoked safely. */
2040 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2041 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2042 type of object is Lisp_String). INHERIT is passed to
2043 INSERT_FROM_STRING_FUNC as the last argument. */
2046 general_insert_function (insert_func
, insert_from_string_func
,
2047 inherit
, nargs
, args
)
2048 void (*insert_func
) P_ ((const unsigned char *, int));
2049 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2051 register Lisp_Object
*args
;
2053 register int argnum
;
2054 register Lisp_Object val
;
2056 for (argnum
= 0; argnum
< nargs
; argnum
++)
2062 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2065 if (!NILP (current_buffer
->enable_multibyte_characters
))
2066 len
= CHAR_STRING (XFASTINT (val
), str
);
2069 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2071 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2074 (*insert_func
) (str
, len
);
2076 else if (STRINGP (val
))
2078 (*insert_from_string_func
) (val
, 0, 0,
2085 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2099 /* Callers passing one argument to Finsert need not gcpro the
2100 argument "array", since the only element of the array will
2101 not be used after calling insert or insert_from_string, so
2102 we don't care if it gets trashed. */
2104 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2105 doc
: /* Insert the arguments, either strings or characters, at point.
2106 Point and before-insertion markers move forward to end up
2107 after the inserted text.
2108 Any other markers at the point of insertion remain before the text.
2110 If the current buffer is multibyte, unibyte strings are converted
2111 to multibyte for insertion (see `string-make-multibyte').
2112 If the current buffer is unibyte, multibyte strings are converted
2113 to unibyte for insertion (see `string-make-unibyte').
2115 When operating on binary data, it may be necessary to preserve the
2116 original bytes of a unibyte string when inserting it into a multibyte
2117 buffer; to accomplish this, apply `string-as-multibyte' to the string
2118 and insert the result.
2120 usage: (insert &rest ARGS) */)
2123 register Lisp_Object
*args
;
2125 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2129 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2131 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2132 Point and before-insertion markers move forward to end up
2133 after the inserted text.
2134 Any other markers at the point of insertion remain before the text.
2136 If the current buffer is multibyte, unibyte strings are converted
2137 to multibyte for insertion (see `unibyte-char-to-multibyte').
2138 If the current buffer is unibyte, multibyte strings are converted
2139 to unibyte for insertion.
2141 usage: (insert-and-inherit &rest ARGS) */)
2144 register Lisp_Object
*args
;
2146 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2151 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2152 doc
: /* Insert strings or characters at point, relocating markers after the text.
2153 Point and markers move forward to end up after the inserted text.
2155 If the current buffer is multibyte, unibyte strings are converted
2156 to multibyte for insertion (see `unibyte-char-to-multibyte').
2157 If the current buffer is unibyte, multibyte strings are converted
2158 to unibyte for insertion.
2160 usage: (insert-before-markers &rest ARGS) */)
2163 register Lisp_Object
*args
;
2165 general_insert_function (insert_before_markers
,
2166 insert_from_string_before_markers
, 0,
2171 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2172 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2173 doc
: /* Insert text at point, relocating markers and inheriting properties.
2174 Point and markers move forward to end up after the inserted text.
2176 If the current buffer is multibyte, unibyte strings are converted
2177 to multibyte for insertion (see `unibyte-char-to-multibyte').
2178 If the current buffer is unibyte, multibyte strings are converted
2179 to unibyte for insertion.
2181 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2184 register Lisp_Object
*args
;
2186 general_insert_function (insert_before_markers_and_inherit
,
2187 insert_from_string_before_markers
, 1,
2192 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2193 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2194 Both arguments are required.
2195 Point, and before-insertion markers, are relocated as in the function `insert'.
2196 The optional third arg INHERIT, if non-nil, says to inherit text properties
2197 from adjoining text, if those properties are sticky. */)
2198 (character
, count
, inherit
)
2199 Lisp_Object character
, count
, inherit
;
2201 register unsigned char *string
;
2202 register int strlen
;
2205 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2207 CHECK_NUMBER (character
);
2208 CHECK_NUMBER (count
);
2210 if (!NILP (current_buffer
->enable_multibyte_characters
))
2211 len
= CHAR_STRING (XFASTINT (character
), str
);
2213 str
[0] = XFASTINT (character
), len
= 1;
2214 n
= XINT (count
) * len
;
2217 strlen
= min (n
, 256 * len
);
2218 string
= (unsigned char *) alloca (strlen
);
2219 for (i
= 0; i
< strlen
; i
++)
2220 string
[i
] = str
[i
% len
];
2224 if (!NILP (inherit
))
2225 insert_and_inherit (string
, strlen
);
2227 insert (string
, strlen
);
2232 if (!NILP (inherit
))
2233 insert_and_inherit (string
, n
);
2241 /* Making strings from buffer contents. */
2243 /* Return a Lisp_String containing the text of the current buffer from
2244 START to END. If text properties are in use and the current buffer
2245 has properties in the range specified, the resulting string will also
2246 have them, if PROPS is nonzero.
2248 We don't want to use plain old make_string here, because it calls
2249 make_uninit_string, which can cause the buffer arena to be
2250 compacted. make_string has no way of knowing that the data has
2251 been moved, and thus copies the wrong data into the string. This
2252 doesn't effect most of the other users of make_string, so it should
2253 be left as is. But we should use this function when conjuring
2254 buffer substrings. */
2257 make_buffer_string (start
, end
, props
)
2261 int start_byte
= CHAR_TO_BYTE (start
);
2262 int end_byte
= CHAR_TO_BYTE (end
);
2264 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2267 /* Return a Lisp_String containing the text of the current buffer from
2268 START / START_BYTE to END / END_BYTE.
2270 If text properties are in use and the current buffer
2271 has properties in the range specified, the resulting string will also
2272 have them, if PROPS is nonzero.
2274 We don't want to use plain old make_string here, because it calls
2275 make_uninit_string, which can cause the buffer arena to be
2276 compacted. make_string has no way of knowing that the data has
2277 been moved, and thus copies the wrong data into the string. This
2278 doesn't effect most of the other users of make_string, so it should
2279 be left as is. But we should use this function when conjuring
2280 buffer substrings. */
2283 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2284 int start
, start_byte
, end
, end_byte
;
2287 Lisp_Object result
, tem
, tem1
;
2289 if (start
< GPT
&& GPT
< end
)
2292 if (! NILP (current_buffer
->enable_multibyte_characters
))
2293 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2295 result
= make_uninit_string (end
- start
);
2296 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2297 end_byte
- start_byte
);
2299 /* If desired, update and copy the text properties. */
2302 update_buffer_properties (start
, end
);
2304 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2305 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2307 if (XINT (tem
) != end
|| !NILP (tem1
))
2308 copy_intervals_to_string (result
, current_buffer
, start
,
2315 /* Call Vbuffer_access_fontify_functions for the range START ... END
2316 in the current buffer, if necessary. */
2319 update_buffer_properties (start
, end
)
2322 /* If this buffer has some access functions,
2323 call them, specifying the range of the buffer being accessed. */
2324 if (!NILP (Vbuffer_access_fontify_functions
))
2326 Lisp_Object args
[3];
2329 args
[0] = Qbuffer_access_fontify_functions
;
2330 XSETINT (args
[1], start
);
2331 XSETINT (args
[2], end
);
2333 /* But don't call them if we can tell that the work
2334 has already been done. */
2335 if (!NILP (Vbuffer_access_fontified_property
))
2337 tem
= Ftext_property_any (args
[1], args
[2],
2338 Vbuffer_access_fontified_property
,
2341 Frun_hook_with_args (3, args
);
2344 Frun_hook_with_args (3, args
);
2348 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2349 doc
: /* Return the contents of part of the current buffer as a string.
2350 The two arguments START and END are character positions;
2351 they can be in either order.
2352 The string returned is multibyte if the buffer is multibyte.
2354 This function copies the text properties of that part of the buffer
2355 into the result string; if you don't want the text properties,
2356 use `buffer-substring-no-properties' instead. */)
2358 Lisp_Object start
, end
;
2362 validate_region (&start
, &end
);
2366 return make_buffer_string (b
, e
, 1);
2369 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2370 Sbuffer_substring_no_properties
, 2, 2, 0,
2371 doc
: /* Return the characters of part of the buffer, without the text properties.
2372 The two arguments START and END are character positions;
2373 they can be in either order. */)
2375 Lisp_Object start
, end
;
2379 validate_region (&start
, &end
);
2383 return make_buffer_string (b
, e
, 0);
2386 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2387 doc
: /* Return the contents of the current buffer as a string.
2388 If narrowing is in effect, this function returns only the visible part
2392 return make_buffer_string (BEGV
, ZV
, 1);
2395 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2397 doc
: /* Insert before point a substring of the contents of BUFFER.
2398 BUFFER may be a buffer or a buffer name.
2399 Arguments START and END are character positions specifying the substring.
2400 They default to the values of (point-min) and (point-max) in BUFFER. */)
2401 (buffer
, start
, end
)
2402 Lisp_Object buffer
, start
, end
;
2404 register int b
, e
, temp
;
2405 register struct buffer
*bp
, *obuf
;
2408 buf
= Fget_buffer (buffer
);
2412 if (NILP (bp
->name
))
2413 error ("Selecting deleted buffer");
2419 CHECK_NUMBER_COERCE_MARKER (start
);
2426 CHECK_NUMBER_COERCE_MARKER (end
);
2431 temp
= b
, b
= e
, e
= temp
;
2433 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2434 args_out_of_range (start
, end
);
2436 obuf
= current_buffer
;
2437 set_buffer_internal_1 (bp
);
2438 update_buffer_properties (b
, e
);
2439 set_buffer_internal_1 (obuf
);
2441 insert_from_buffer (bp
, b
, e
- b
, 0);
2445 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2447 doc
: /* Compare two substrings of two buffers; return result as number.
2448 the value is -N if first string is less after N-1 chars,
2449 +N if first string is greater after N-1 chars, or 0 if strings match.
2450 Each substring is represented as three arguments: BUFFER, START and END.
2451 That makes six args in all, three for each substring.
2453 The value of `case-fold-search' in the current buffer
2454 determines whether case is significant or ignored. */)
2455 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2456 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2458 register int begp1
, endp1
, begp2
, endp2
, temp
;
2459 register struct buffer
*bp1
, *bp2
;
2460 register Lisp_Object
*trt
2461 = (!NILP (current_buffer
->case_fold_search
)
2462 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2464 int i1
, i2
, i1_byte
, i2_byte
;
2466 /* Find the first buffer and its substring. */
2469 bp1
= current_buffer
;
2473 buf1
= Fget_buffer (buffer1
);
2476 bp1
= XBUFFER (buf1
);
2477 if (NILP (bp1
->name
))
2478 error ("Selecting deleted buffer");
2482 begp1
= BUF_BEGV (bp1
);
2485 CHECK_NUMBER_COERCE_MARKER (start1
);
2486 begp1
= XINT (start1
);
2489 endp1
= BUF_ZV (bp1
);
2492 CHECK_NUMBER_COERCE_MARKER (end1
);
2493 endp1
= XINT (end1
);
2497 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2499 if (!(BUF_BEGV (bp1
) <= begp1
2501 && endp1
<= BUF_ZV (bp1
)))
2502 args_out_of_range (start1
, end1
);
2504 /* Likewise for second substring. */
2507 bp2
= current_buffer
;
2511 buf2
= Fget_buffer (buffer2
);
2514 bp2
= XBUFFER (buf2
);
2515 if (NILP (bp2
->name
))
2516 error ("Selecting deleted buffer");
2520 begp2
= BUF_BEGV (bp2
);
2523 CHECK_NUMBER_COERCE_MARKER (start2
);
2524 begp2
= XINT (start2
);
2527 endp2
= BUF_ZV (bp2
);
2530 CHECK_NUMBER_COERCE_MARKER (end2
);
2531 endp2
= XINT (end2
);
2535 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2537 if (!(BUF_BEGV (bp2
) <= begp2
2539 && endp2
<= BUF_ZV (bp2
)))
2540 args_out_of_range (start2
, end2
);
2544 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2545 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2547 while (i1
< endp1
&& i2
< endp2
)
2549 /* When we find a mismatch, we must compare the
2550 characters, not just the bytes. */
2555 if (! NILP (bp1
->enable_multibyte_characters
))
2557 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2558 BUF_INC_POS (bp1
, i1_byte
);
2563 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2564 c1
= unibyte_char_to_multibyte (c1
);
2568 if (! NILP (bp2
->enable_multibyte_characters
))
2570 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2571 BUF_INC_POS (bp2
, i2_byte
);
2576 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2577 c2
= unibyte_char_to_multibyte (c2
);
2583 c1
= XINT (trt
[c1
]);
2584 c2
= XINT (trt
[c2
]);
2587 return make_number (- 1 - chars
);
2589 return make_number (chars
+ 1);
2594 /* The strings match as far as they go.
2595 If one is shorter, that one is less. */
2596 if (chars
< endp1
- begp1
)
2597 return make_number (chars
+ 1);
2598 else if (chars
< endp2
- begp2
)
2599 return make_number (- chars
- 1);
2601 /* Same length too => they are equal. */
2602 return make_number (0);
2606 subst_char_in_region_unwind (arg
)
2609 return current_buffer
->undo_list
= arg
;
2613 subst_char_in_region_unwind_1 (arg
)
2616 return current_buffer
->filename
= arg
;
2619 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2620 Ssubst_char_in_region
, 4, 5, 0,
2621 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2622 If optional arg NOUNDO is non-nil, don't record this change for undo
2623 and don't mark the buffer as really changed.
2624 Both characters must have the same length of multi-byte form. */)
2625 (start
, end
, fromchar
, tochar
, noundo
)
2626 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2628 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2630 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2632 int count
= SPECPDL_INDEX ();
2633 #define COMBINING_NO 0
2634 #define COMBINING_BEFORE 1
2635 #define COMBINING_AFTER 2
2636 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2637 int maybe_byte_combining
= COMBINING_NO
;
2638 int last_changed
= 0;
2639 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2641 validate_region (&start
, &end
);
2642 CHECK_NUMBER (fromchar
);
2643 CHECK_NUMBER (tochar
);
2647 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2648 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2649 error ("Characters in subst-char-in-region have different byte-lengths");
2650 if (!ASCII_BYTE_P (*tostr
))
2652 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2653 complete multibyte character, it may be combined with the
2654 after bytes. If it is in the range 0xA0..0xFF, it may be
2655 combined with the before and after bytes. */
2656 if (!CHAR_HEAD_P (*tostr
))
2657 maybe_byte_combining
= COMBINING_BOTH
;
2658 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2659 maybe_byte_combining
= COMBINING_AFTER
;
2665 fromstr
[0] = XFASTINT (fromchar
);
2666 tostr
[0] = XFASTINT (tochar
);
2670 pos_byte
= CHAR_TO_BYTE (pos
);
2671 stop
= CHAR_TO_BYTE (XINT (end
));
2674 /* If we don't want undo, turn off putting stuff on the list.
2675 That's faster than getting rid of things,
2676 and it prevents even the entry for a first change.
2677 Also inhibit locking the file. */
2680 record_unwind_protect (subst_char_in_region_unwind
,
2681 current_buffer
->undo_list
);
2682 current_buffer
->undo_list
= Qt
;
2683 /* Don't do file-locking. */
2684 record_unwind_protect (subst_char_in_region_unwind_1
,
2685 current_buffer
->filename
);
2686 current_buffer
->filename
= Qnil
;
2689 if (pos_byte
< GPT_BYTE
)
2690 stop
= min (stop
, GPT_BYTE
);
2693 int pos_byte_next
= pos_byte
;
2695 if (pos_byte
>= stop
)
2697 if (pos_byte
>= end_byte
) break;
2700 p
= BYTE_POS_ADDR (pos_byte
);
2702 INC_POS (pos_byte_next
);
2705 if (pos_byte_next
- pos_byte
== len
2706 && p
[0] == fromstr
[0]
2708 || (p
[1] == fromstr
[1]
2709 && (len
== 2 || (p
[2] == fromstr
[2]
2710 && (len
== 3 || p
[3] == fromstr
[3]))))))
2715 modify_region (current_buffer
, changed
, XINT (end
));
2717 if (! NILP (noundo
))
2719 if (MODIFF
- 1 == SAVE_MODIFF
)
2721 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2722 current_buffer
->auto_save_modified
++;
2726 /* Take care of the case where the new character
2727 combines with neighboring bytes. */
2728 if (maybe_byte_combining
2729 && (maybe_byte_combining
== COMBINING_AFTER
2730 ? (pos_byte_next
< Z_BYTE
2731 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2732 : ((pos_byte_next
< Z_BYTE
2733 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2734 || (pos_byte
> BEG_BYTE
2735 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2737 Lisp_Object tem
, string
;
2739 struct gcpro gcpro1
;
2741 tem
= current_buffer
->undo_list
;
2744 /* Make a multibyte string containing this single character. */
2745 string
= make_multibyte_string (tostr
, 1, len
);
2746 /* replace_range is less efficient, because it moves the gap,
2747 but it handles combining correctly. */
2748 replace_range (pos
, pos
+ 1, string
,
2750 pos_byte_next
= CHAR_TO_BYTE (pos
);
2751 if (pos_byte_next
> pos_byte
)
2752 /* Before combining happened. We should not increment
2753 POS. So, to cancel the later increment of POS,
2757 INC_POS (pos_byte_next
);
2759 if (! NILP (noundo
))
2760 current_buffer
->undo_list
= tem
;
2767 record_change (pos
, 1);
2768 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2770 last_changed
= pos
+ 1;
2772 pos_byte
= pos_byte_next
;
2778 signal_after_change (changed
,
2779 last_changed
- changed
, last_changed
- changed
);
2780 update_compositions (changed
, last_changed
, CHECK_ALL
);
2783 unbind_to (count
, Qnil
);
2787 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2788 Stranslate_region_internal
, 3, 3, 0,
2789 doc
: /* Internal use only.
2790 From START to END, translate characters according to TABLE.
2791 TABLE is a string; the Nth character in it is the mapping
2792 for the character with code N.
2793 It returns the number of characters changed. */)
2797 register Lisp_Object table
;
2799 register unsigned char *tt
; /* Trans table. */
2800 register int nc
; /* New character. */
2801 int cnt
; /* Number of changes made. */
2802 int size
; /* Size of translate table. */
2803 int pos
, pos_byte
, end_pos
;
2804 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2805 int string_multibyte
;
2807 validate_region (&start
, &end
);
2808 if (CHAR_TABLE_P (table
))
2815 CHECK_STRING (table
);
2817 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2818 table
= string_make_unibyte (table
);
2819 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2820 size
= SCHARS (table
);
2825 pos_byte
= CHAR_TO_BYTE (pos
);
2826 end_pos
= XINT (end
);
2827 modify_region (current_buffer
, pos
, XINT (end
));
2830 for (; pos
< end_pos
; )
2832 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2833 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2838 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2845 if (string_multibyte
)
2847 str
= tt
+ string_char_to_byte (table
, oc
);
2848 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2854 if (! ASCII_BYTE_P (nc
) && multibyte
)
2856 str_len
= CHAR_STRING (nc
, buf
);
2872 val
= CHAR_TABLE_REF (table
, oc
);
2874 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2877 str_len
= CHAR_STRING (nc
, buf
);
2888 /* This is less efficient, because it moves the gap,
2889 but it should multibyte characters correctly. */
2890 string
= make_multibyte_string (str
, 1, str_len
);
2891 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2896 record_change (pos
, 1);
2897 while (str_len
-- > 0)
2899 signal_after_change (pos
, 1, 1);
2900 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2909 return make_number (cnt
);
2912 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2913 doc
: /* Delete the text between point and mark.
2915 When called from a program, expects two arguments,
2916 positions (integers or markers) specifying the stretch to be deleted. */)
2918 Lisp_Object start
, end
;
2920 validate_region (&start
, &end
);
2921 del_range (XINT (start
), XINT (end
));
2925 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2926 Sdelete_and_extract_region
, 2, 2, 0,
2927 doc
: /* Delete the text between START and END and return it. */)
2929 Lisp_Object start
, end
;
2931 validate_region (&start
, &end
);
2932 if (XINT (start
) == XINT (end
))
2933 return build_string ("");
2934 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2937 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2938 doc
: /* Remove restrictions (narrowing) from current buffer.
2939 This allows the buffer's full text to be seen and edited. */)
2942 if (BEG
!= BEGV
|| Z
!= ZV
)
2943 current_buffer
->clip_changed
= 1;
2945 BEGV_BYTE
= BEG_BYTE
;
2946 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2947 /* Changing the buffer bounds invalidates any recorded current column. */
2948 invalidate_current_column ();
2952 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2953 doc
: /* Restrict editing in this buffer to the current region.
2954 The rest of the text becomes temporarily invisible and untouchable
2955 but is not deleted; if you save the buffer in a file, the invisible
2956 text is included in the file. \\[widen] makes all visible again.
2957 See also `save-restriction'.
2959 When calling from a program, pass two arguments; positions (integers
2960 or markers) bounding the text that should remain visible. */)
2962 register Lisp_Object start
, end
;
2964 CHECK_NUMBER_COERCE_MARKER (start
);
2965 CHECK_NUMBER_COERCE_MARKER (end
);
2967 if (XINT (start
) > XINT (end
))
2970 tem
= start
; start
= end
; end
= tem
;
2973 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2974 args_out_of_range (start
, end
);
2976 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2977 current_buffer
->clip_changed
= 1;
2979 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2980 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
2981 if (PT
< XFASTINT (start
))
2982 SET_PT (XFASTINT (start
));
2983 if (PT
> XFASTINT (end
))
2984 SET_PT (XFASTINT (end
));
2985 /* Changing the buffer bounds invalidates any recorded current column. */
2986 invalidate_current_column ();
2991 save_restriction_save ()
2993 if (BEGV
== BEG
&& ZV
== Z
)
2994 /* The common case that the buffer isn't narrowed.
2995 We return just the buffer object, which save_restriction_restore
2996 recognizes as meaning `no restriction'. */
2997 return Fcurrent_buffer ();
2999 /* We have to save a restriction, so return a pair of markers, one
3000 for the beginning and one for the end. */
3002 Lisp_Object beg
, end
;
3004 beg
= buildmark (BEGV
, BEGV_BYTE
);
3005 end
= buildmark (ZV
, ZV_BYTE
);
3007 /* END must move forward if text is inserted at its exact location. */
3008 XMARKER(end
)->insertion_type
= 1;
3010 return Fcons (beg
, end
);
3015 save_restriction_restore (data
)
3019 /* A pair of marks bounding a saved restriction. */
3021 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3022 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3023 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3025 if (buf
/* Verify marker still points to a buffer. */
3026 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3027 /* The restriction has changed from the saved one, so restore
3028 the saved restriction. */
3030 int pt
= BUF_PT (buf
);
3032 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3033 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3035 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3036 /* The point is outside the new visible range, move it inside. */
3037 SET_BUF_PT_BOTH (buf
,
3038 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3039 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3042 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3046 /* A buffer, which means that there was no old restriction. */
3048 struct buffer
*buf
= XBUFFER (data
);
3050 if (buf
/* Verify marker still points to a buffer. */
3051 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3052 /* The buffer has been narrowed, get rid of the narrowing. */
3054 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3055 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3057 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3064 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3065 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3066 The buffer's restrictions make parts of the beginning and end invisible.
3067 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3068 This special form, `save-restriction', saves the current buffer's restrictions
3069 when it is entered, and restores them when it is exited.
3070 So any `narrow-to-region' within BODY lasts only until the end of the form.
3071 The old restrictions settings are restored
3072 even in case of abnormal exit (throw or error).
3074 The value returned is the value of the last form in BODY.
3076 Note: if you are using both `save-excursion' and `save-restriction',
3077 use `save-excursion' outermost:
3078 (save-excursion (save-restriction ...))
3080 usage: (save-restriction &rest BODY) */)
3084 register Lisp_Object val
;
3085 int count
= SPECPDL_INDEX ();
3087 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3088 val
= Fprogn (body
);
3089 return unbind_to (count
, val
);
3092 /* Buffer for the most recent text displayed by Fmessage_box. */
3093 static char *message_text
;
3095 /* Allocated length of that buffer. */
3096 static int message_length
;
3098 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3099 doc
: /* Print a one-line message at the bottom of the screen.
3100 The message also goes into the `*Messages*' buffer.
3101 \(In keyboard macros, that's all it does.)
3103 The first argument is a format control string, and the rest are data
3104 to be formatted under control of the string. See `format' for details.
3106 If the first argument is nil, the function clears any existing message;
3107 this lets the minibuffer contents show. See also `current-message'.
3109 usage: (message STRING &rest ARGS) */)
3115 || (STRINGP (args
[0])
3116 && SBYTES (args
[0]) == 0))
3123 register Lisp_Object val
;
3124 val
= Fformat (nargs
, args
);
3125 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3130 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3131 doc
: /* Display a message, in a dialog box if possible.
3132 If a dialog box is not available, use the echo area.
3133 The first argument is a format control string, and the rest are data
3134 to be formatted under control of the string. See `format' for details.
3136 If the first argument is nil, clear any existing message; let the
3137 minibuffer contents show.
3139 usage: (message-box STRING &rest ARGS) */)
3151 register Lisp_Object val
;
3152 val
= Fformat (nargs
, args
);
3154 /* The MS-DOS frames support popup menus even though they are
3155 not FRAME_WINDOW_P. */
3156 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3157 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3159 Lisp_Object pane
, menu
, obj
;
3160 struct gcpro gcpro1
;
3161 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3163 menu
= Fcons (val
, pane
);
3164 obj
= Fx_popup_dialog (Qt
, menu
);
3168 #endif /* HAVE_MENUS */
3169 /* Copy the data so that it won't move when we GC. */
3172 message_text
= (char *)xmalloc (80);
3173 message_length
= 80;
3175 if (SBYTES (val
) > message_length
)
3177 message_length
= SBYTES (val
);
3178 message_text
= (char *)xrealloc (message_text
, message_length
);
3180 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3181 message2 (message_text
, SBYTES (val
),
3182 STRING_MULTIBYTE (val
));
3187 extern Lisp_Object last_nonmenu_event
;
3190 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3191 doc
: /* Display a message in a dialog box or in the echo area.
3192 If this command was invoked with the mouse, use a dialog box if
3193 `use-dialog-box' is non-nil.
3194 Otherwise, use the echo area.
3195 The first argument is a format control string, and the rest are data
3196 to be formatted under control of the string. See `format' for details.
3198 If the first argument is nil, clear any existing message; let the
3199 minibuffer contents show.
3201 usage: (message-or-box STRING &rest ARGS) */)
3207 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3209 return Fmessage_box (nargs
, args
);
3211 return Fmessage (nargs
, args
);
3214 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3215 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3218 return current_message ();
3222 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3223 doc
: /* Return a copy of STRING with text properties added.
3224 First argument is the string to copy.
3225 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3226 properties to add to the result.
3227 usage: (propertize STRING &rest PROPERTIES) */)
3232 Lisp_Object properties
, string
;
3233 struct gcpro gcpro1
, gcpro2
;
3236 /* Number of args must be odd. */
3237 if ((nargs
& 1) == 0 || nargs
< 1)
3238 error ("Wrong number of arguments");
3240 properties
= string
= Qnil
;
3241 GCPRO2 (properties
, string
);
3243 /* First argument must be a string. */
3244 CHECK_STRING (args
[0]);
3245 string
= Fcopy_sequence (args
[0]);
3247 for (i
= 1; i
< nargs
; i
+= 2)
3249 CHECK_SYMBOL (args
[i
]);
3250 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3253 Fadd_text_properties (make_number (0),
3254 make_number (SCHARS (string
)),
3255 properties
, string
);
3256 RETURN_UNGCPRO (string
);
3260 /* Number of bytes that STRING will occupy when put into the result.
3261 MULTIBYTE is nonzero if the result should be multibyte. */
3263 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3264 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3265 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3268 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3269 doc
: /* Format a string out of a control-string and arguments.
3270 The first argument is a control string.
3271 The other arguments are substituted into it to make the result, a string.
3272 It may contain %-sequences meaning to substitute the next argument.
3273 %s means print a string argument. Actually, prints any object, with `princ'.
3274 %d means print as number in decimal (%o octal, %x hex).
3275 %X is like %x, but uses upper case.
3276 %e means print a number in exponential notation.
3277 %f means print a number in decimal-point notation.
3278 %g means print a number in exponential notation
3279 or decimal-point notation, whichever uses fewer characters.
3280 %c means print a number as a single character.
3281 %S means print any object as an s-expression (using `prin1').
3282 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3283 Use %% to put a single % into the output.
3285 The basic structure of a %-sequence is
3286 % <flags> <width> <precision> character
3287 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3289 usage: (format STRING &rest OBJECTS) */)
3292 register Lisp_Object
*args
;
3294 register int n
; /* The number of the next arg to substitute */
3295 register int total
; /* An estimate of the final length */
3297 register unsigned char *format
, *end
, *format_start
;
3299 /* Nonzero if the output should be a multibyte string,
3300 which is true if any of the inputs is one. */
3302 /* When we make a multibyte string, we must pay attention to the
3303 byte combining problem, i.e., a byte may be combined with a
3304 multibyte charcter of the previous string. This flag tells if we
3305 must consider such a situation or not. */
3306 int maybe_combine_byte
;
3307 unsigned char *this_format
;
3308 /* Precision for each spec, or -1, a flag value meaning no precision
3309 was given in that spec. Element 0, corresonding to the format
3310 string itself, will not be used. Element NARGS, corresponding to
3311 no argument, *will* be assigned to in the case that a `%' and `.'
3312 occur after the final format specifier. */
3313 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3316 int arg_intervals
= 0;
3319 /* discarded[I] is 1 if byte I of the format
3320 string was not copied into the output.
3321 It is 2 if byte I was not the first byte of its character. */
3322 char *discarded
= 0;
3324 /* Each element records, for one argument,
3325 the start and end bytepos in the output string,
3326 and whether the argument is a string with intervals.
3327 info[0] is unused. Unused elements have -1 for start. */
3330 int start
, end
, intervals
;
3333 /* It should not be necessary to GCPRO ARGS, because
3334 the caller in the interpreter should take care of that. */
3336 /* Try to determine whether the result should be multibyte.
3337 This is not always right; sometimes the result needs to be multibyte
3338 because of an object that we will pass through prin1,
3339 and in that case, we won't know it here. */
3340 for (n
= 0; n
< nargs
; n
++)
3342 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3344 /* Piggyback on this loop to initialize precision[N]. */
3347 precision
[nargs
] = -1;
3349 CHECK_STRING (args
[0]);
3350 /* We may have to change "%S" to "%s". */
3351 args
[0] = Fcopy_sequence (args
[0]);
3353 /* GC should never happen here, so abort if it does. */
3356 /* If we start out planning a unibyte result,
3357 then discover it has to be multibyte, we jump back to retry.
3358 That can only happen from the first large while loop below. */
3361 format
= SDATA (args
[0]);
3362 format_start
= format
;
3363 end
= format
+ SBYTES (args
[0]);
3366 /* Make room in result for all the non-%-codes in the control string. */
3367 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3369 /* Allocate the info and discarded tables. */
3371 int nbytes
= (nargs
+1) * sizeof *info
;
3374 info
= (struct info
*) alloca (nbytes
);
3375 bzero (info
, nbytes
);
3376 for (i
= 0; i
<= nargs
; i
++)
3379 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3380 bzero (discarded
, SBYTES (args
[0]));
3383 /* Add to TOTAL enough space to hold the converted arguments. */
3386 while (format
!= end
)
3387 if (*format
++ == '%')
3390 int actual_width
= 0;
3391 unsigned char *this_format_start
= format
- 1;
3392 int field_width
= 0;
3394 /* General format specifications look like
3396 '%' [flags] [field-width] [precision] format
3401 field-width ::= [0-9]+
3402 precision ::= '.' [0-9]*
3404 If a field-width is specified, it specifies to which width
3405 the output should be padded with blanks, iff the output
3406 string is shorter than field-width.
3408 If precision is specified, it specifies the number of
3409 digits to print after the '.' for floats, or the max.
3410 number of chars to print from a string. */
3412 while (index ("-0# ", *format
))
3415 if (*format
>= '0' && *format
<= '9')
3417 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3418 field_width
= 10 * field_width
+ *format
- '0';
3421 /* N is not incremented for another few lines below, so refer to
3422 element N+1 (which might be precision[NARGS]). */
3426 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3427 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3430 if (format
- this_format_start
+ 1 > longest_format
)
3431 longest_format
= format
- this_format_start
+ 1;
3434 error ("Format string ends in middle of format specifier");
3437 else if (++n
>= nargs
)
3438 error ("Not enough arguments for format string");
3439 else if (*format
== 'S')
3441 /* For `S', prin1 the argument and then treat like a string. */
3442 register Lisp_Object tem
;
3443 tem
= Fprin1_to_string (args
[n
], Qnil
);
3444 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3450 /* If we restart the loop, we should not come here again
3451 because args[n] is now a string and calling
3452 Fprin1_to_string on it produces superflous double
3453 quotes. So, change "%S" to "%s" now. */
3457 else if (SYMBOLP (args
[n
]))
3459 args
[n
] = SYMBOL_NAME (args
[n
]);
3460 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3467 else if (STRINGP (args
[n
]))
3470 if (*format
!= 's' && *format
!= 'S')
3471 error ("Format specifier doesn't match argument type");
3472 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3473 to be as large as is calculated here. Easy check for
3474 the case PRECISION = 0. */
3475 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3476 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3478 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3479 else if (INTEGERP (args
[n
]) && *format
!= 's')
3481 /* The following loop assumes the Lisp type indicates
3482 the proper way to pass the argument.
3483 So make sure we have a flonum if the argument should
3485 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3486 args
[n
] = Ffloat (args
[n
]);
3488 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3489 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3490 error ("Invalid format operation %%%c", *format
);
3495 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3496 /* Note: No one can remember why we have to treat
3497 the character 0 as a multibyte character here.
3498 But, until it causes a real problem, let's
3500 || XINT (args
[n
]) == 0)
3507 args
[n
] = Fchar_to_string (args
[n
]);
3508 thissize
= SBYTES (args
[n
]);
3510 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3513 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3514 thissize
= SBYTES (args
[n
]);
3518 else if (FLOATP (args
[n
]) && *format
!= 's')
3520 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3522 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3523 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3524 error ("Invalid format operation %%%c", *format
);
3525 args
[n
] = Ftruncate (args
[n
], Qnil
);
3528 /* Note that we're using sprintf to print floats,
3529 so we have to take into account what that function
3531 /* Filter out flag value of -1. */
3532 thissize
= (MAX_10_EXP
+ 100
3533 + (precision
[n
] > 0 ? precision
[n
] : 0));
3537 /* Anything but a string, convert to a string using princ. */
3538 register Lisp_Object tem
;
3539 tem
= Fprin1_to_string (args
[n
], Qt
);
3540 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3549 thissize
+= max (0, field_width
- actual_width
);
3550 total
+= thissize
+ 4;
3555 /* Now we can no longer jump to retry.
3556 TOTAL and LONGEST_FORMAT are known for certain. */
3558 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3560 /* Allocate the space for the result.
3561 Note that TOTAL is an overestimate. */
3562 SAFE_ALLOCA (buf
, char *, total
);
3568 /* Scan the format and store result in BUF. */
3569 format
= SDATA (args
[0]);
3570 format_start
= format
;
3571 end
= format
+ SBYTES (args
[0]);
3572 maybe_combine_byte
= 0;
3573 while (format
!= end
)
3579 unsigned char *this_format_start
= format
;
3581 discarded
[format
- format_start
] = 1;
3584 while (index("-0# ", *format
))
3590 discarded
[format
- format_start
] = 1;
3594 minlen
= atoi (format
);
3596 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3598 discarded
[format
- format_start
] = 1;
3602 if (*format
++ == '%')
3611 discarded
[format
- format_start
- 1] = 1;
3612 info
[n
].start
= nchars
;
3614 if (STRINGP (args
[n
]))
3616 /* handle case (precision[n] >= 0) */
3619 int nbytes
, start
, end
;
3622 /* lisp_string_width ignores a precision of 0, but GNU
3623 libc functions print 0 characters when the precision
3624 is 0. Imitate libc behavior here. Changing
3625 lisp_string_width is the right thing, and will be
3626 done, but meanwhile we work with it. */
3628 if (precision
[n
] == 0)
3629 width
= nchars_string
= nbytes
= 0;
3630 else if (precision
[n
] > 0)
3631 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3633 { /* no precision spec given for this argument */
3634 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3635 nbytes
= SBYTES (args
[n
]);
3636 nchars_string
= SCHARS (args
[n
]);
3639 /* If spec requires it, pad on right with spaces. */
3640 padding
= minlen
- width
;
3642 while (padding
-- > 0)
3649 nchars
+= nchars_string
;
3654 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3655 && STRING_MULTIBYTE (args
[n
])
3656 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3657 maybe_combine_byte
= 1;
3659 p
+= copy_text (SDATA (args
[n
]), p
,
3661 STRING_MULTIBYTE (args
[n
]), multibyte
);
3664 while (padding
-- > 0)
3670 /* If this argument has text properties, record where
3671 in the result string it appears. */
3672 if (STRING_INTERVALS (args
[n
]))
3673 info
[n
].intervals
= arg_intervals
= 1;
3675 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3679 bcopy (this_format_start
, this_format
,
3680 format
- this_format_start
);
3681 this_format
[format
- this_format_start
] = 0;
3683 if (INTEGERP (args
[n
]))
3684 sprintf (p
, this_format
, XINT (args
[n
]));
3686 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3690 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3691 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3692 maybe_combine_byte
= 1;
3693 this_nchars
= strlen (p
);
3695 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3698 nchars
+= this_nchars
;
3701 info
[n
].end
= nchars
;
3703 else if (STRING_MULTIBYTE (args
[0]))
3705 /* Copy a whole multibyte character. */
3708 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3709 && !CHAR_HEAD_P (*format
))
3710 maybe_combine_byte
= 1;
3712 while (! CHAR_HEAD_P (*format
))
3714 discarded
[format
- format_start
] = 2;
3721 /* Convert a single-byte character to multibyte. */
3722 int len
= copy_text (format
, p
, 1, 0, 1);
3729 *p
++ = *format
++, nchars
++;
3732 if (p
> buf
+ total
)
3735 if (maybe_combine_byte
)
3736 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3737 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3739 /* If we allocated BUF with malloc, free it too. */
3742 /* If the format string has text properties, or any of the string
3743 arguments has text properties, set up text properties of the
3746 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3748 Lisp_Object len
, new_len
, props
;
3749 struct gcpro gcpro1
;
3751 /* Add text properties from the format string. */
3752 len
= make_number (SCHARS (args
[0]));
3753 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3758 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3761 /* Adjust the bounds of each text property
3762 to the proper start and end in the output string. */
3764 /* Put the positions in PROPS in increasing order, so that
3765 we can do (effectively) one scan through the position
3766 space of the format string. */
3767 props
= Fnreverse (props
);
3769 /* BYTEPOS is the byte position in the format string,
3770 POSITION is the untranslated char position in it,
3771 TRANSLATED is the translated char position in BUF,
3772 and ARGN is the number of the next arg we will come to. */
3773 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3780 /* First adjust the property start position. */
3781 pos
= XINT (XCAR (item
));
3783 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3784 up to this position. */
3785 for (; position
< pos
; bytepos
++)
3787 if (! discarded
[bytepos
])
3788 position
++, translated
++;
3789 else if (discarded
[bytepos
] == 1)
3792 if (translated
== info
[argn
].start
)
3794 translated
+= info
[argn
].end
- info
[argn
].start
;
3800 XSETCAR (item
, make_number (translated
));
3802 /* Likewise adjust the property end position. */
3803 pos
= XINT (XCAR (XCDR (item
)));
3805 for (; bytepos
< pos
; bytepos
++)
3807 if (! discarded
[bytepos
])
3808 position
++, translated
++;
3809 else if (discarded
[bytepos
] == 1)
3812 if (translated
== info
[argn
].start
)
3814 translated
+= info
[argn
].end
- info
[argn
].start
;
3820 XSETCAR (XCDR (item
), make_number (translated
));
3823 add_text_properties_from_list (val
, props
, make_number (0));
3826 /* Add text properties from arguments. */
3828 for (n
= 1; n
< nargs
; ++n
)
3829 if (info
[n
].intervals
)
3831 len
= make_number (SCHARS (args
[n
]));
3832 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3833 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3834 extend_property_ranges (props
, len
, new_len
);
3835 /* If successive arguments have properites, be sure that
3836 the value of `composition' property be the copy. */
3837 if (n
> 1 && info
[n
- 1].end
)
3838 make_composition_value_copy (props
);
3839 add_text_properties_from_list (val
, props
,
3840 make_number (info
[n
].start
));
3850 format2 (string1
, arg0
, arg1
)
3852 Lisp_Object arg0
, arg1
;
3854 Lisp_Object args
[3];
3855 args
[0] = build_string (string1
);
3858 return Fformat (3, args
);
3861 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3862 doc
: /* Return t if two characters match, optionally ignoring case.
3863 Both arguments must be characters (i.e. integers).
3864 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3866 register Lisp_Object c1
, c2
;
3872 if (XINT (c1
) == XINT (c2
))
3874 if (NILP (current_buffer
->case_fold_search
))
3877 /* Do these in separate statements,
3878 then compare the variables.
3879 because of the way DOWNCASE uses temp variables. */
3880 i1
= DOWNCASE (XFASTINT (c1
));
3881 i2
= DOWNCASE (XFASTINT (c2
));
3882 return (i1
== i2
? Qt
: Qnil
);
3885 /* Transpose the markers in two regions of the current buffer, and
3886 adjust the ones between them if necessary (i.e.: if the regions
3889 START1, END1 are the character positions of the first region.
3890 START1_BYTE, END1_BYTE are the byte positions.
3891 START2, END2 are the character positions of the second region.
3892 START2_BYTE, END2_BYTE are the byte positions.
3894 Traverses the entire marker list of the buffer to do so, adding an
3895 appropriate amount to some, subtracting from some, and leaving the
3896 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3898 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3901 transpose_markers (start1
, end1
, start2
, end2
,
3902 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3903 register int start1
, end1
, start2
, end2
;
3904 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3906 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3907 register struct Lisp_Marker
*marker
;
3909 /* Update point as if it were a marker. */
3913 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3914 PT_BYTE
+ (end2_byte
- end1_byte
));
3915 else if (PT
< start2
)
3916 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3917 (PT_BYTE
+ (end2_byte
- start2_byte
)
3918 - (end1_byte
- start1_byte
)));
3920 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3921 PT_BYTE
- (start2_byte
- start1_byte
));
3923 /* We used to adjust the endpoints here to account for the gap, but that
3924 isn't good enough. Even if we assume the caller has tried to move the
3925 gap out of our way, it might still be at start1 exactly, for example;
3926 and that places it `inside' the interval, for our purposes. The amount
3927 of adjustment is nontrivial if there's a `denormalized' marker whose
3928 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3929 the dirty work to Fmarker_position, below. */
3931 /* The difference between the region's lengths */
3932 diff
= (end2
- start2
) - (end1
- start1
);
3933 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3935 /* For shifting each marker in a region by the length of the other
3936 region plus the distance between the regions. */
3937 amt1
= (end2
- start2
) + (start2
- end1
);
3938 amt2
= (end1
- start1
) + (start2
- end1
);
3939 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3940 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3942 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
3944 mpos
= marker
->bytepos
;
3945 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3947 if (mpos
< end1_byte
)
3949 else if (mpos
< start2_byte
)
3953 marker
->bytepos
= mpos
;
3955 mpos
= marker
->charpos
;
3956 if (mpos
>= start1
&& mpos
< end2
)
3960 else if (mpos
< start2
)
3965 marker
->charpos
= mpos
;
3969 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
3970 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
3971 The regions may not be overlapping, because the size of the buffer is
3972 never changed in a transposition.
3974 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
3975 any markers that happen to be located in the regions.
3977 Transposing beyond buffer boundaries is an error. */)
3978 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
3979 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
3981 register int start1
, end1
, start2
, end2
;
3982 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
3983 int gap
, len1
, len_mid
, len2
;
3984 unsigned char *start1_addr
, *start2_addr
, *temp
;
3986 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
3987 cur_intv
= BUF_INTERVALS (current_buffer
);
3989 validate_region (&startr1
, &endr1
);
3990 validate_region (&startr2
, &endr2
);
3992 start1
= XFASTINT (startr1
);
3993 end1
= XFASTINT (endr1
);
3994 start2
= XFASTINT (startr2
);
3995 end2
= XFASTINT (endr2
);
3998 /* Swap the regions if they're reversed. */
4001 register int glumph
= start1
;
4009 len1
= end1
- start1
;
4010 len2
= end2
- start2
;
4013 error ("Transposed regions overlap");
4014 else if (start1
== end1
|| start2
== end2
)
4015 error ("Transposed region has length 0");
4017 /* The possibilities are:
4018 1. Adjacent (contiguous) regions, or separate but equal regions
4019 (no, really equal, in this case!), or
4020 2. Separate regions of unequal size.
4022 The worst case is usually No. 2. It means that (aside from
4023 potential need for getting the gap out of the way), there also
4024 needs to be a shifting of the text between the two regions. So
4025 if they are spread far apart, we are that much slower... sigh. */
4027 /* It must be pointed out that the really studly thing to do would
4028 be not to move the gap at all, but to leave it in place and work
4029 around it if necessary. This would be extremely efficient,
4030 especially considering that people are likely to do
4031 transpositions near where they are working interactively, which
4032 is exactly where the gap would be found. However, such code
4033 would be much harder to write and to read. So, if you are
4034 reading this comment and are feeling squirrely, by all means have
4035 a go! I just didn't feel like doing it, so I will simply move
4036 the gap the minimum distance to get it out of the way, and then
4037 deal with an unbroken array. */
4039 /* Make sure the gap won't interfere, by moving it out of the text
4040 we will operate on. */
4041 if (start1
< gap
&& gap
< end2
)
4043 if (gap
- start1
< end2
- gap
)
4049 start1_byte
= CHAR_TO_BYTE (start1
);
4050 start2_byte
= CHAR_TO_BYTE (start2
);
4051 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4052 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4054 #ifdef BYTE_COMBINING_DEBUG
4057 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4058 len2_byte
, start1
, start1_byte
)
4059 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4060 len1_byte
, end2
, start2_byte
+ len2_byte
)
4061 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4062 len1_byte
, end2
, start2_byte
+ len2_byte
))
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
, start2
, start2_byte
)
4071 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4072 len2_byte
, end1
, start1_byte
+ len1_byte
)
4073 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4074 len1_byte
, end2
, start2_byte
+ len2_byte
))
4079 /* Hmmm... how about checking to see if the gap is large
4080 enough to use as the temporary storage? That would avoid an
4081 allocation... interesting. Later, don't fool with it now. */
4083 /* Working without memmove, for portability (sigh), so must be
4084 careful of overlapping subsections of the array... */
4086 if (end1
== start2
) /* adjacent regions */
4088 modify_region (current_buffer
, start1
, end2
);
4089 record_change (start1
, len1
+ len2
);
4091 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4092 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4093 Fset_text_properties (make_number (start1
), make_number (end2
),
4096 /* First region smaller than second. */
4097 if (len1_byte
< len2_byte
)
4101 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4103 /* Don't precompute these addresses. We have to compute them
4104 at the last minute, because the relocating allocator might
4105 have moved the buffer around during the xmalloc. */
4106 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4107 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4109 bcopy (start2_addr
, temp
, len2_byte
);
4110 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4111 bcopy (temp
, start1_addr
, len2_byte
);
4115 /* First region not smaller than second. */
4119 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4120 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4121 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4122 bcopy (start1_addr
, temp
, len1_byte
);
4123 bcopy (start2_addr
, start1_addr
, len2_byte
);
4124 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4127 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4128 len1
, current_buffer
, 0);
4129 graft_intervals_into_buffer (tmp_interval2
, start1
,
4130 len2
, current_buffer
, 0);
4131 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4132 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4134 /* Non-adjacent regions, because end1 != start2, bleagh... */
4137 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4139 if (len1_byte
== len2_byte
)
4140 /* Regions are same size, though, how nice. */
4144 modify_region (current_buffer
, start1
, end1
);
4145 modify_region (current_buffer
, start2
, end2
);
4146 record_change (start1
, len1
);
4147 record_change (start2
, len2
);
4148 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4149 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4150 Fset_text_properties (make_number (start1
), make_number (end1
),
4152 Fset_text_properties (make_number (start2
), make_number (end2
),
4155 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4156 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4157 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4158 bcopy (start1_addr
, temp
, len1_byte
);
4159 bcopy (start2_addr
, start1_addr
, len2_byte
);
4160 bcopy (temp
, start2_addr
, len1_byte
);
4163 graft_intervals_into_buffer (tmp_interval1
, start2
,
4164 len1
, current_buffer
, 0);
4165 graft_intervals_into_buffer (tmp_interval2
, start1
,
4166 len2
, current_buffer
, 0);
4169 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4170 /* Non-adjacent & unequal size, area between must also be shifted. */
4174 modify_region (current_buffer
, start1
, end2
);
4175 record_change (start1
, (end2
- start1
));
4176 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4177 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4178 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4179 Fset_text_properties (make_number (start1
), make_number (end2
),
4182 /* holds region 2 */
4183 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4184 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4185 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4186 bcopy (start2_addr
, temp
, len2_byte
);
4187 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4188 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4189 bcopy (temp
, start1_addr
, len2_byte
);
4192 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4193 len1
, current_buffer
, 0);
4194 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4195 len_mid
, current_buffer
, 0);
4196 graft_intervals_into_buffer (tmp_interval2
, start1
,
4197 len2
, current_buffer
, 0);
4200 /* Second region smaller than first. */
4204 record_change (start1
, (end2
- start1
));
4205 modify_region (current_buffer
, start1
, end2
);
4207 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4208 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4209 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4210 Fset_text_properties (make_number (start1
), make_number (end2
),
4213 /* holds region 1 */
4214 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4215 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4216 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4217 bcopy (start1_addr
, temp
, len1_byte
);
4218 bcopy (start2_addr
, start1_addr
, len2_byte
);
4219 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4220 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4223 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4224 len1
, current_buffer
, 0);
4225 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4226 len_mid
, current_buffer
, 0);
4227 graft_intervals_into_buffer (tmp_interval2
, start1
,
4228 len2
, current_buffer
, 0);
4231 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4232 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4235 /* When doing multiple transpositions, it might be nice
4236 to optimize this. Perhaps the markers in any one buffer
4237 should be organized in some sorted data tree. */
4238 if (NILP (leave_markers
))
4240 transpose_markers (start1
, end1
, start2
, end2
,
4241 start1_byte
, start1_byte
+ len1_byte
,
4242 start2_byte
, start2_byte
+ len2_byte
);
4243 fix_start_end_in_overlays (start1
, end2
);
4255 Qbuffer_access_fontify_functions
4256 = intern ("buffer-access-fontify-functions");
4257 staticpro (&Qbuffer_access_fontify_functions
);
4259 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4260 doc
: /* Non-nil means text motion commands don't notice fields. */);
4261 Vinhibit_field_text_motion
= Qnil
;
4263 DEFVAR_LISP ("buffer-access-fontify-functions",
4264 &Vbuffer_access_fontify_functions
,
4265 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4266 Each function is called with two arguments which specify the range
4267 of the buffer being accessed. */);
4268 Vbuffer_access_fontify_functions
= Qnil
;
4272 extern Lisp_Object Vprin1_to_string_buffer
;
4273 obuf
= Fcurrent_buffer ();
4274 /* Do this here, because init_buffer_once is too early--it won't work. */
4275 Fset_buffer (Vprin1_to_string_buffer
);
4276 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4277 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4282 DEFVAR_LISP ("buffer-access-fontified-property",
4283 &Vbuffer_access_fontified_property
,
4284 doc
: /* Property which (if non-nil) indicates text has been fontified.
4285 `buffer-substring' need not call the `buffer-access-fontify-functions'
4286 functions if all the text being accessed has this property. */);
4287 Vbuffer_access_fontified_property
= Qnil
;
4289 DEFVAR_LISP ("system-name", &Vsystem_name
,
4290 doc
: /* The name of the machine Emacs is running on. */);
4292 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4293 doc
: /* The full name of the user logged in. */);
4295 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4296 doc
: /* The user's name, taken from environment variables if possible. */);
4298 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4299 doc
: /* The user's name, based upon the real uid only. */);
4301 defsubr (&Spropertize
);
4302 defsubr (&Schar_equal
);
4303 defsubr (&Sgoto_char
);
4304 defsubr (&Sstring_to_char
);
4305 defsubr (&Schar_to_string
);
4306 defsubr (&Sbuffer_substring
);
4307 defsubr (&Sbuffer_substring_no_properties
);
4308 defsubr (&Sbuffer_string
);
4310 defsubr (&Spoint_marker
);
4311 defsubr (&Smark_marker
);
4313 defsubr (&Sregion_beginning
);
4314 defsubr (&Sregion_end
);
4316 staticpro (&Qfield
);
4317 Qfield
= intern ("field");
4318 staticpro (&Qboundary
);
4319 Qboundary
= intern ("boundary");
4320 defsubr (&Sfield_beginning
);
4321 defsubr (&Sfield_end
);
4322 defsubr (&Sfield_string
);
4323 defsubr (&Sfield_string_no_properties
);
4324 defsubr (&Sdelete_field
);
4325 defsubr (&Sconstrain_to_field
);
4327 defsubr (&Sline_beginning_position
);
4328 defsubr (&Sline_end_position
);
4330 /* defsubr (&Smark); */
4331 /* defsubr (&Sset_mark); */
4332 defsubr (&Ssave_excursion
);
4333 defsubr (&Ssave_current_buffer
);
4335 defsubr (&Sbufsize
);
4336 defsubr (&Spoint_max
);
4337 defsubr (&Spoint_min
);
4338 defsubr (&Spoint_min_marker
);
4339 defsubr (&Spoint_max_marker
);
4340 defsubr (&Sgap_position
);
4341 defsubr (&Sgap_size
);
4342 defsubr (&Sposition_bytes
);
4343 defsubr (&Sbyte_to_position
);
4349 defsubr (&Sfollowing_char
);
4350 defsubr (&Sprevious_char
);
4351 defsubr (&Schar_after
);
4352 defsubr (&Schar_before
);
4354 defsubr (&Sinsert_before_markers
);
4355 defsubr (&Sinsert_and_inherit
);
4356 defsubr (&Sinsert_and_inherit_before_markers
);
4357 defsubr (&Sinsert_char
);
4359 defsubr (&Suser_login_name
);
4360 defsubr (&Suser_real_login_name
);
4361 defsubr (&Suser_uid
);
4362 defsubr (&Suser_real_uid
);
4363 defsubr (&Suser_full_name
);
4364 defsubr (&Semacs_pid
);
4365 defsubr (&Scurrent_time
);
4366 defsubr (&Sget_internal_run_time
);
4367 defsubr (&Sformat_time_string
);
4368 defsubr (&Sfloat_time
);
4369 defsubr (&Sdecode_time
);
4370 defsubr (&Sencode_time
);
4371 defsubr (&Scurrent_time_string
);
4372 defsubr (&Scurrent_time_zone
);
4373 defsubr (&Sset_time_zone_rule
);
4374 defsubr (&Ssystem_name
);
4375 defsubr (&Smessage
);
4376 defsubr (&Smessage_box
);
4377 defsubr (&Smessage_or_box
);
4378 defsubr (&Scurrent_message
);
4381 defsubr (&Sinsert_buffer_substring
);
4382 defsubr (&Scompare_buffer_substrings
);
4383 defsubr (&Ssubst_char_in_region
);
4384 defsubr (&Stranslate_region_internal
);
4385 defsubr (&Sdelete_region
);
4386 defsubr (&Sdelete_and_extract_region
);
4388 defsubr (&Snarrow_to_region
);
4389 defsubr (&Ssave_restriction
);
4390 defsubr (&Stranspose_regions
);
4393 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4394 (do not change this comment) */