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
45 #include "intervals.h"
56 #define MAX_10_EXP DBL_MAX_10_EXP
58 #define MAX_10_EXP 310
66 extern char **environ
;
69 extern Lisp_Object make_time
P_ ((time_t));
70 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
71 const struct tm
*, int));
72 static int tm_diff
P_ ((struct tm
*, struct tm
*));
73 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
74 static void update_buffer_properties
P_ ((int, int));
75 static Lisp_Object region_limit
P_ ((int));
76 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
77 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
78 size_t, const struct tm
*, int));
79 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
80 void (*) (Lisp_Object
, int, int, int,
82 int, int, Lisp_Object
*));
83 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
84 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
85 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
88 extern char *index
P_ ((const char *, int));
91 Lisp_Object Vbuffer_access_fontify_functions
;
92 Lisp_Object Qbuffer_access_fontify_functions
;
93 Lisp_Object Vbuffer_access_fontified_property
;
95 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
97 /* Non-nil means don't stop at field boundary in text motion commands. */
99 Lisp_Object Vinhibit_field_text_motion
;
101 /* Some static data, and a function to initialize it for each run */
103 Lisp_Object Vsystem_name
;
104 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
105 Lisp_Object Vuser_full_name
; /* full name of current user */
106 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
108 /* Symbol for the text property used to mark fields. */
112 /* A special value for Qfield properties. */
114 Lisp_Object Qboundary
;
121 register unsigned char *p
;
122 struct passwd
*pw
; /* password entry for the current user */
125 /* Set up system_name even when dumping. */
129 /* Don't bother with this on initial start when just dumping out */
132 #endif /* not CANNOT_DUMP */
134 pw
= (struct passwd
*) getpwuid (getuid ());
136 /* We let the real user name default to "root" because that's quite
137 accurate on MSDOG and because it lets Emacs find the init file.
138 (The DVX libraries override the Djgpp libraries here.) */
139 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
141 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
144 /* Get the effective user name, by consulting environment variables,
145 or the effective uid if those are unset. */
146 user_name
= (char *) getenv ("LOGNAME");
149 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
150 #else /* WINDOWSNT */
151 user_name
= (char *) getenv ("USER");
152 #endif /* WINDOWSNT */
155 pw
= (struct passwd
*) getpwuid (geteuid ());
156 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
158 Vuser_login_name
= build_string (user_name
);
160 /* If the user name claimed in the environment vars differs from
161 the real uid, use the claimed name to find the full name. */
162 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
163 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
166 p
= (unsigned char *) getenv ("NAME");
168 Vuser_full_name
= build_string (p
);
169 else if (NILP (Vuser_full_name
))
170 Vuser_full_name
= build_string ("unknown");
173 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
174 doc
: /* Convert arg CHAR to a string containing that character.
175 usage: (char-to-string CHAR) */)
177 Lisp_Object character
;
180 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
182 CHECK_NUMBER (character
);
184 len
= (SINGLE_BYTE_CHAR_P (XFASTINT (character
))
185 ? (*str
= (unsigned char)(XFASTINT (character
)), 1)
186 : char_to_string (XFASTINT (character
), str
));
187 return make_string_from_bytes (str
, 1, len
);
190 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
191 doc
: /* Convert arg STRING to a character, the first character of that string.
192 A multibyte character is handled correctly. */)
194 register Lisp_Object string
;
196 register Lisp_Object val
;
197 CHECK_STRING (string
);
200 if (STRING_MULTIBYTE (string
))
201 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
203 XSETFASTINT (val
, SREF (string
, 0));
206 XSETFASTINT (val
, 0);
211 buildmark (charpos
, bytepos
)
212 int charpos
, bytepos
;
214 register Lisp_Object mark
;
215 mark
= Fmake_marker ();
216 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
220 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
221 doc
: /* Return value of point, as an integer.
222 Beginning of buffer is position (point-min). */)
226 XSETFASTINT (temp
, PT
);
230 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
231 doc
: /* Return value of point, as a marker object. */)
234 return buildmark (PT
, PT_BYTE
);
238 clip_to_bounds (lower
, num
, upper
)
239 int lower
, num
, upper
;
243 else if (num
> upper
)
249 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
250 doc
: /* Set point to POSITION, a number or marker.
251 Beginning of buffer is position (point-min), end is (point-max).
252 If the position is in the middle of a multibyte form,
253 the actual point is set at the head of the multibyte form
254 except in the case that `enable-multibyte-characters' is nil. */)
256 register Lisp_Object position
;
260 if (MARKERP (position
)
261 && current_buffer
== XMARKER (position
)->buffer
)
263 pos
= marker_position (position
);
265 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
267 SET_PT_BOTH (ZV
, ZV_BYTE
);
269 SET_PT_BOTH (pos
, marker_byte_position (position
));
274 CHECK_NUMBER_COERCE_MARKER (position
);
276 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
282 /* Return the start or end position of the region.
283 BEGINNINGP non-zero means return the start.
284 If there is no region active, signal an error. */
287 region_limit (beginningp
)
290 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
293 if (!NILP (Vtransient_mark_mode
)
294 && NILP (Vmark_even_if_inactive
)
295 && NILP (current_buffer
->mark_active
))
296 Fsignal (Qmark_inactive
, Qnil
);
298 m
= Fmarker_position (current_buffer
->mark
);
300 error ("The mark is not set now, so there is no region");
302 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
303 m
= make_number (PT
);
307 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
308 doc
: /* Return position of beginning of region, as an integer. */)
311 return region_limit (1);
314 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
315 doc
: /* Return position of end of region, as an integer. */)
318 return region_limit (0);
321 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
322 doc
: /* Return this buffer's mark, as a marker object.
323 Watch out! Moving this marker changes the mark position.
324 If you set the marker not to point anywhere, the buffer will have no mark. */)
327 return current_buffer
->mark
;
331 /* Find all the overlays in the current buffer that touch position POS.
332 Return the number found, and store them in a vector in VEC
336 overlays_around (pos
, vec
, len
)
341 Lisp_Object overlay
, start
, end
;
342 struct Lisp_Overlay
*tail
;
343 int startpos
, endpos
;
346 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
348 XSETMISC (overlay
, tail
);
350 end
= OVERLAY_END (overlay
);
351 endpos
= OVERLAY_POSITION (end
);
354 start
= OVERLAY_START (overlay
);
355 startpos
= OVERLAY_POSITION (start
);
360 /* Keep counting overlays even if we can't return them all. */
365 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
367 XSETMISC (overlay
, tail
);
369 start
= OVERLAY_START (overlay
);
370 startpos
= OVERLAY_POSITION (start
);
373 end
= OVERLAY_END (overlay
);
374 endpos
= OVERLAY_POSITION (end
);
386 /* Return the value of property PROP, in OBJECT at POSITION.
387 It's the value of PROP that a char inserted at POSITION would get.
388 OBJECT is optional and defaults to the current buffer.
389 If OBJECT is a buffer, then overlay properties are considered as well as
391 If OBJECT is a window, then that window's buffer is used, but
392 window-specific overlays are considered only if they are associated
395 get_pos_property (position
, prop
, object
)
396 Lisp_Object position
, object
;
397 register Lisp_Object prop
;
399 CHECK_NUMBER_COERCE_MARKER (position
);
402 XSETBUFFER (object
, current_buffer
);
403 else if (WINDOWP (object
))
404 object
= XWINDOW (object
)->buffer
;
406 if (!BUFFERP (object
))
407 /* pos-property only makes sense in buffers right now, since strings
408 have no overlays and no notion of insertion for which stickiness
410 return Fget_text_property (position
, prop
, object
);
413 int posn
= XINT (position
);
415 Lisp_Object
*overlay_vec
, tem
;
416 struct buffer
*obuf
= current_buffer
;
418 set_buffer_temp (XBUFFER (object
));
420 /* First try with room for 40 overlays. */
422 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
423 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
425 /* If there are more than 40,
426 make enough space for all, and try again. */
429 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
430 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
432 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
434 set_buffer_temp (obuf
);
436 /* Now check the overlays in order of decreasing priority. */
437 while (--noverlays
>= 0)
439 Lisp_Object ol
= overlay_vec
[noverlays
];
440 tem
= Foverlay_get (ol
, prop
);
443 /* Check the overlay is indeed active at point. */
444 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
445 if ((OVERLAY_POSITION (start
) == posn
446 && XMARKER (start
)->insertion_type
== 1)
447 || (OVERLAY_POSITION (finish
) == posn
448 && XMARKER (finish
)->insertion_type
== 0))
449 ; /* The overlay will not cover a char inserted at point. */
457 { /* Now check the text-properties. */
458 int stickiness
= text_property_stickiness (prop
, position
, object
);
460 return Fget_text_property (position
, prop
, object
);
461 else if (stickiness
< 0
462 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
463 return Fget_text_property (make_number (XINT (position
) - 1),
471 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
472 the value of point is used instead. If BEG or END null,
473 means don't store the beginning or end of the field.
475 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
476 results; they do not effect boundary behavior.
478 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
479 position of a field, then the beginning of the previous field is
480 returned instead of the beginning of POS's field (since the end of a
481 field is actually also the beginning of the next input field, this
482 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
483 true case, if two fields are separated by a field with the special
484 value `boundary', and POS lies within it, then the two separated
485 fields are considered to be adjacent, and POS between them, when
486 finding the beginning and ending of the "merged" field.
488 Either BEG or END may be 0, in which case the corresponding value
492 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
494 Lisp_Object merge_at_boundary
;
495 Lisp_Object beg_limit
, end_limit
;
498 /* Fields right before and after the point. */
499 Lisp_Object before_field
, after_field
;
500 /* 1 if POS counts as the start of a field. */
501 int at_field_start
= 0;
502 /* 1 if POS counts as the end of a field. */
503 int at_field_end
= 0;
506 XSETFASTINT (pos
, PT
);
508 CHECK_NUMBER_COERCE_MARKER (pos
);
511 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
513 = (XFASTINT (pos
) > BEGV
514 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
518 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
519 and POS is at beginning of a field, which can also be interpreted
520 as the end of the previous field. Note that the case where if
521 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
522 more natural one; then we avoid treating the beginning of a field
524 if (NILP (merge_at_boundary
))
526 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
527 if (!EQ (field
, after_field
))
529 if (!EQ (field
, before_field
))
531 if (NILP (field
) && at_field_start
&& at_field_end
)
532 /* If an inserted char would have a nil field while the surrounding
533 text is non-nil, we're probably not looking at a
534 zero-length field, but instead at a non-nil field that's
535 not intended for editing (such as comint's prompts). */
536 at_field_end
= at_field_start
= 0;
539 /* Note about special `boundary' fields:
541 Consider the case where the point (`.') is between the fields `x' and `y':
545 In this situation, if merge_at_boundary is true, we consider the
546 `x' and `y' fields as forming one big merged field, and so the end
547 of the field is the end of `y'.
549 However, if `x' and `y' are separated by a special `boundary' field
550 (a field with a `field' char-property of 'boundary), then we ignore
551 this special field when merging adjacent fields. Here's the same
552 situation, but with a `boundary' field between the `x' and `y' fields:
556 Here, if point is at the end of `x', the beginning of `y', or
557 anywhere in-between (within the `boundary' field), we merge all
558 three fields and consider the beginning as being the beginning of
559 the `x' field, and the end as being the end of the `y' field. */
564 /* POS is at the edge of a field, and we should consider it as
565 the beginning of the following field. */
566 *beg
= XFASTINT (pos
);
568 /* Find the previous field boundary. */
571 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
572 /* Skip a `boundary' field. */
573 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
576 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
578 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
585 /* POS is at the edge of a field, and we should consider it as
586 the end of the previous field. */
587 *end
= XFASTINT (pos
);
589 /* Find the next field boundary. */
591 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
592 /* Skip a `boundary' field. */
593 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
596 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
598 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
604 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
605 doc
: /* Delete the field surrounding POS.
606 A field is a region of text with the same `field' property.
607 If POS is nil, the value of point is used for POS. */)
612 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
614 del_range (beg
, end
);
618 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
619 doc
: /* Return the contents of the field surrounding POS as a string.
620 A field is a region of text with the same `field' property.
621 If POS is nil, the value of point is used for POS. */)
626 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
627 return make_buffer_string (beg
, end
, 1);
630 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
631 doc
: /* Return the contents of the field around POS, without text-properties.
632 A field is a region of text with the same `field' property.
633 If POS is nil, the value of point is used for POS. */)
638 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
639 return make_buffer_string (beg
, end
, 0);
642 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
643 doc
: /* Return the beginning of the field surrounding POS.
644 A field is a region of text with the same `field' property.
645 If POS is nil, the value of point is used for POS.
646 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
647 field, then the beginning of the *previous* field is returned.
648 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
649 is before LIMIT, then LIMIT will be returned instead. */)
650 (pos
, escape_from_edge
, limit
)
651 Lisp_Object pos
, escape_from_edge
, limit
;
654 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
655 return make_number (beg
);
658 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
659 doc
: /* Return the end of the field surrounding POS.
660 A field is a region of text with the same `field' property.
661 If POS is nil, the value of point is used for POS.
662 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
663 then the end of the *following* field is returned.
664 If LIMIT is non-nil, it is a buffer position; if the end of the field
665 is after LIMIT, then LIMIT will be returned instead. */)
666 (pos
, escape_from_edge
, limit
)
667 Lisp_Object pos
, escape_from_edge
, limit
;
670 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
671 return make_number (end
);
674 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
675 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
677 A field is a region of text with the same `field' property.
678 If NEW-POS is nil, then the current point is used instead, and set to the
679 constrained position if that is different.
681 If OLD-POS is at the boundary of two fields, then the allowable
682 positions for NEW-POS depends on the value of the optional argument
683 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
684 constrained to the field that has the same `field' char-property
685 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
686 is non-nil, NEW-POS is constrained to the union of the two adjacent
687 fields. Additionally, if two fields are separated by another field with
688 the special value `boundary', then any point within this special field is
689 also considered to be `on the boundary'.
691 If the optional argument ONLY-IN-LINE is non-nil and constraining
692 NEW-POS would move it to a different line, NEW-POS is returned
693 unconstrained. This useful for commands that move by line, like
694 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
695 only in the case where they can still move to the right line.
697 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
698 a non-nil property of that name, then any field boundaries are ignored.
700 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
701 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
702 Lisp_Object new_pos
, old_pos
;
703 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
705 /* If non-zero, then the original point, before re-positioning. */
709 /* Use the current point, and afterwards, set it. */
712 XSETFASTINT (new_pos
, PT
);
715 if (NILP (Vinhibit_field_text_motion
)
716 && !EQ (new_pos
, old_pos
)
717 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
718 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
719 && (NILP (inhibit_capture_property
)
720 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
721 /* NEW_POS is not within the same field as OLD_POS; try to
722 move NEW_POS so that it is. */
725 Lisp_Object field_bound
;
727 CHECK_NUMBER_COERCE_MARKER (new_pos
);
728 CHECK_NUMBER_COERCE_MARKER (old_pos
);
730 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
733 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
735 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
737 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
738 other side of NEW_POS, which would mean that NEW_POS is
739 already acceptable, and it's not necessary to constrain it
741 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
742 /* NEW_POS should be constrained, but only if either
743 ONLY_IN_LINE is nil (in which case any constraint is OK),
744 or NEW_POS and FIELD_BOUND are on the same line (in which
745 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
746 && (NILP (only_in_line
)
747 /* This is the ONLY_IN_LINE case, check that NEW_POS and
748 FIELD_BOUND are on the same line by seeing whether
749 there's an intervening newline or not. */
750 || (scan_buffer ('\n',
751 XFASTINT (new_pos
), XFASTINT (field_bound
),
752 fwd
? -1 : 1, &shortage
, 1),
754 /* Constrain NEW_POS to FIELD_BOUND. */
755 new_pos
= field_bound
;
757 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
758 /* The NEW_POS argument was originally nil, so automatically set PT. */
759 SET_PT (XFASTINT (new_pos
));
766 DEFUN ("line-beginning-position",
767 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
768 doc
: /* Return the character position of the first character on the current line.
769 With argument N not nil or 1, move forward N - 1 lines first.
770 If scan reaches end of buffer, return that position.
772 The scan does not cross a field boundary unless doing so would move
773 beyond there to a different line; if N is nil or 1, and scan starts at a
774 field boundary, the scan stops as soon as it starts. To ignore field
775 boundaries bind `inhibit-field-text-motion' to t.
777 This function does not move point. */)
781 int orig
, orig_byte
, end
;
790 Fforward_line (make_number (XINT (n
) - 1));
793 SET_PT_BOTH (orig
, orig_byte
);
795 /* Return END constrained to the current input field. */
796 return Fconstrain_to_field (make_number (end
), make_number (orig
),
797 XINT (n
) != 1 ? Qt
: Qnil
,
801 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
802 doc
: /* Return the character position of the last character on the current line.
803 With argument N not nil or 1, move forward N - 1 lines first.
804 If scan reaches end of buffer, return that position.
806 The scan does not cross a field boundary unless doing so would move
807 beyond there to a different line; if N is nil or 1, and scan starts at a
808 field boundary, the scan stops as soon as it starts. To ignore field
809 boundaries bind `inhibit-field-text-motion' to t.
811 This function does not move point. */)
823 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
825 /* Return END_POS constrained to the current input field. */
826 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
832 save_excursion_save ()
834 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
837 return Fcons (Fpoint_marker (),
838 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
839 Fcons (visible
? Qt
: Qnil
,
840 Fcons (current_buffer
->mark_active
,
845 save_excursion_restore (info
)
848 Lisp_Object tem
, tem1
, omark
, nmark
;
849 struct gcpro gcpro1
, gcpro2
, gcpro3
;
852 tem
= Fmarker_buffer (XCAR (info
));
853 /* If buffer being returned to is now deleted, avoid error */
854 /* Otherwise could get error here while unwinding to top level
856 /* In that case, Fmarker_buffer returns nil now. */
860 omark
= nmark
= Qnil
;
861 GCPRO3 (info
, omark
, nmark
);
868 unchain_marker (XMARKER (tem
));
873 omark
= Fmarker_position (current_buffer
->mark
);
874 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
875 nmark
= Fmarker_position (tem
);
876 unchain_marker (XMARKER (tem
));
880 visible_p
= !NILP (XCAR (info
));
882 #if 0 /* We used to make the current buffer visible in the selected window
883 if that was true previously. That avoids some anomalies.
884 But it creates others, and it wasn't documented, and it is simpler
885 and cleaner never to alter the window/buffer connections. */
888 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
889 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
895 tem1
= current_buffer
->mark_active
;
896 current_buffer
->mark_active
= tem
;
898 if (!NILP (Vrun_hooks
))
900 /* If mark is active now, and either was not active
901 or was at a different place, run the activate hook. */
902 if (! NILP (current_buffer
->mark_active
))
904 if (! EQ (omark
, nmark
))
905 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
907 /* If mark has ceased to be active, run deactivate hook. */
908 else if (! NILP (tem1
))
909 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
912 /* If buffer was visible in a window, and a different window was
913 selected, and the old selected window is still showing this
914 buffer, restore point in that window. */
917 && !EQ (tem
, selected_window
)
918 && (tem1
= XWINDOW (tem
)->buffer
,
919 (/* Window is live... */
921 /* ...and it shows the current buffer. */
922 && XBUFFER (tem1
) == current_buffer
)))
923 Fset_window_point (tem
, make_number (PT
));
929 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
930 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
931 Executes BODY just like `progn'.
932 The values of point, mark and the current buffer are restored
933 even in case of abnormal exit (throw or error).
934 The state of activation of the mark is also restored.
936 This construct does not save `deactivate-mark', and therefore
937 functions that change the buffer will still cause deactivation
938 of the mark at the end of the command. To prevent that, bind
939 `deactivate-mark' with `let'.
941 usage: (save-excursion &rest BODY) */)
945 register Lisp_Object val
;
946 int count
= SPECPDL_INDEX ();
948 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
951 return unbind_to (count
, val
);
954 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
955 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
956 Executes BODY just like `progn'.
957 usage: (save-current-buffer &rest BODY) */)
962 int count
= SPECPDL_INDEX ();
964 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
967 return unbind_to (count
, val
);
970 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
971 doc
: /* Return the number of characters in the current buffer.
972 If BUFFER, return the number of characters in that buffer instead. */)
977 return make_number (Z
- BEG
);
980 CHECK_BUFFER (buffer
);
981 return make_number (BUF_Z (XBUFFER (buffer
))
982 - BUF_BEG (XBUFFER (buffer
)));
986 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
987 doc
: /* Return the minimum permissible value of point in the current buffer.
988 This is 1, unless narrowing (a buffer restriction) is in effect. */)
992 XSETFASTINT (temp
, BEGV
);
996 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
997 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
998 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1001 return buildmark (BEGV
, BEGV_BYTE
);
1004 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1005 doc
: /* Return the maximum permissible value of point in the current buffer.
1006 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1007 is in effect, in which case it is less. */)
1011 XSETFASTINT (temp
, ZV
);
1015 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1016 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1017 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1018 is in effect, in which case it is less. */)
1021 return buildmark (ZV
, ZV_BYTE
);
1024 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1025 doc
: /* Return the position of the gap, in the current buffer.
1026 See also `gap-size'. */)
1030 XSETFASTINT (temp
, GPT
);
1034 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1035 doc
: /* Return the size of the current buffer's gap.
1036 See also `gap-position'. */)
1040 XSETFASTINT (temp
, GAP_SIZE
);
1044 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1045 doc
: /* Return the byte position for character position POSITION.
1046 If POSITION is out of range, the value is nil. */)
1048 Lisp_Object position
;
1050 CHECK_NUMBER_COERCE_MARKER (position
);
1051 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1053 return make_number (CHAR_TO_BYTE (XINT (position
)));
1056 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1057 doc
: /* Return the character position for byte position BYTEPOS.
1058 If BYTEPOS is out of range, the value is nil. */)
1060 Lisp_Object bytepos
;
1062 CHECK_NUMBER (bytepos
);
1063 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1065 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1068 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1069 doc
: /* Return the character following point, as a number.
1070 At the end of the buffer or accessible region, return 0. */)
1075 XSETFASTINT (temp
, 0);
1077 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1081 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1082 doc
: /* Return the character preceding point, as a number.
1083 At the beginning of the buffer or accessible region, return 0. */)
1088 XSETFASTINT (temp
, 0);
1089 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1093 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1096 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1100 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1101 doc
: /* Return t if point is at the beginning of the buffer.
1102 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1110 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1111 doc
: /* Return t if point is at the end of the buffer.
1112 If the buffer is narrowed, this means the end of the narrowed part. */)
1120 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1121 doc
: /* Return t if point is at the beginning of a line. */)
1124 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1129 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1130 doc
: /* Return t if point is at the end of a line.
1131 `End of a line' includes point being at the end of the buffer. */)
1134 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1139 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1140 doc
: /* Return character in current buffer at position POS.
1141 POS is an integer or a marker and defaults to point.
1142 If POS is out of range, the value is nil. */)
1146 register int pos_byte
;
1151 XSETFASTINT (pos
, PT
);
1156 pos_byte
= marker_byte_position (pos
);
1157 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1162 CHECK_NUMBER_COERCE_MARKER (pos
);
1163 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1166 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1169 return make_number (FETCH_CHAR (pos_byte
));
1172 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1173 doc
: /* Return character in current buffer preceding position POS.
1174 POS is an integer or a marker and defaults to point.
1175 If POS is out of range, the value is nil. */)
1179 register Lisp_Object val
;
1180 register int pos_byte
;
1185 XSETFASTINT (pos
, PT
);
1190 pos_byte
= marker_byte_position (pos
);
1192 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1197 CHECK_NUMBER_COERCE_MARKER (pos
);
1199 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1202 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1205 if (!NILP (current_buffer
->enable_multibyte_characters
))
1208 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1213 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1218 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1219 doc
: /* Return the name under which the user logged in, as a string.
1220 This is based on the effective uid, not the real uid.
1221 Also, if the environment variables LOGNAME or USER are set,
1222 that determines the value of this function.
1224 If optional argument UID is an integer, return the login name of the user
1225 with that uid, or nil if there is no such user. */)
1231 /* Set up the user name info if we didn't do it before.
1232 (That can happen if Emacs is dumpable
1233 but you decide to run `temacs -l loadup' and not dump. */
1234 if (INTEGERP (Vuser_login_name
))
1238 return Vuser_login_name
;
1241 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1242 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1245 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1247 doc
: /* Return the name of the user's real uid, as a string.
1248 This ignores the environment variables LOGNAME and USER, so it differs from
1249 `user-login-name' when running under `su'. */)
1252 /* Set up the user name info if we didn't do it before.
1253 (That can happen if Emacs is dumpable
1254 but you decide to run `temacs -l loadup' and not dump. */
1255 if (INTEGERP (Vuser_login_name
))
1257 return Vuser_real_login_name
;
1260 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1261 doc
: /* Return the effective uid of Emacs.
1262 Value is an integer or float, depending on the value. */)
1265 return make_fixnum_or_float (geteuid ());
1268 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1269 doc
: /* Return the real uid of Emacs.
1270 Value is an integer or float, depending on the value. */)
1273 return make_fixnum_or_float (getuid ());
1276 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1277 doc
: /* Return the full name of the user logged in, as a string.
1278 If the full name corresponding to Emacs's userid is not known,
1281 If optional argument UID is an integer or float, return the full name
1282 of the user with that uid, or nil if there is no such user.
1283 If UID is a string, return the full name of the user with that login
1284 name, or nil if there is no such user. */)
1289 register unsigned char *p
, *q
;
1293 return Vuser_full_name
;
1294 else if (NUMBERP (uid
))
1295 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1296 else if (STRINGP (uid
))
1297 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1299 error ("Invalid UID specification");
1304 p
= (unsigned char *) USER_FULL_NAME
;
1305 /* Chop off everything after the first comma. */
1306 q
= (unsigned char *) index (p
, ',');
1307 full
= make_string (p
, q
? q
- p
: strlen (p
));
1309 #ifdef AMPERSAND_FULL_NAME
1311 q
= (unsigned char *) index (p
, '&');
1312 /* Substitute the login name for the &, upcasing the first character. */
1315 register unsigned char *r
;
1318 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1319 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1320 bcopy (p
, r
, q
- p
);
1322 strcat (r
, SDATA (login
));
1323 r
[q
- p
] = UPCASE (r
[q
- p
]);
1325 full
= build_string (r
);
1327 #endif /* AMPERSAND_FULL_NAME */
1332 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1333 doc
: /* Return the name of the machine you are running on, as a string. */)
1336 return Vsystem_name
;
1339 /* For the benefit of callers who don't want to include lisp.h */
1344 if (STRINGP (Vsystem_name
))
1345 return (char *) SDATA (Vsystem_name
);
1350 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1351 doc
: /* Return the process ID of Emacs, as an integer. */)
1354 return make_number (getpid ());
1357 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1358 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1359 The time is returned as a list of three integers. The first has the
1360 most significant 16 bits of the seconds, while the second has the
1361 least significant 16 bits. The third integer gives the microsecond
1364 The microsecond count is zero on systems that do not provide
1365 resolution finer than a second. */)
1369 Lisp_Object result
[3];
1372 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1373 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1374 XSETINT (result
[2], EMACS_USECS (t
));
1376 return Flist (3, result
);
1381 lisp_time_argument (specified_time
, result
, usec
)
1382 Lisp_Object specified_time
;
1386 if (NILP (specified_time
))
1393 *usec
= EMACS_USECS (t
);
1394 *result
= EMACS_SECS (t
);
1398 return time (result
) != -1;
1402 Lisp_Object high
, low
;
1403 high
= Fcar (specified_time
);
1404 CHECK_NUMBER (high
);
1405 low
= Fcdr (specified_time
);
1410 Lisp_Object usec_l
= Fcdr (low
);
1412 usec_l
= Fcar (usec_l
);
1417 CHECK_NUMBER (usec_l
);
1418 *usec
= XINT (usec_l
);
1426 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1427 return *result
>> 16 == XINT (high
);
1431 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1432 doc
: /* Return the current time, as a float number of seconds since the epoch.
1433 If SPECIFIED-TIME is given, it is the time to convert to float
1434 instead of the current time. The argument should have the form
1435 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1436 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1437 have the form (HIGH . LOW), but this is considered obsolete.
1439 WARNING: Since the result is floating point, it may not be exact.
1440 Do not use this function if precise time stamps are required. */)
1442 Lisp_Object specified_time
;
1447 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1448 error ("Invalid time specification");
1450 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1453 /* Write information into buffer S of size MAXSIZE, according to the
1454 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1455 Default to Universal Time if UT is nonzero, local time otherwise.
1456 Return the number of bytes written, not including the terminating
1457 '\0'. If S is NULL, nothing will be written anywhere; so to
1458 determine how many bytes would be written, use NULL for S and
1459 ((size_t) -1) for MAXSIZE.
1461 This function behaves like emacs_strftimeu, except it allows null
1464 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1469 const struct tm
*tp
;
1474 /* Loop through all the null-terminated strings in the format
1475 argument. Normally there's just one null-terminated string, but
1476 there can be arbitrarily many, concatenated together, if the
1477 format contains '\0' bytes. emacs_strftimeu stops at the first
1478 '\0' byte so we must invoke it separately for each such string. */
1487 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1491 if (result
== 0 && s
[0] != '\0')
1496 maxsize
-= result
+ 1;
1498 len
= strlen (format
);
1499 if (len
== format_len
)
1503 format_len
-= len
+ 1;
1507 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1508 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1509 TIME is specified as (HIGH LOW . IGNORED), as returned by
1510 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1511 is also still accepted.
1512 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1513 as Universal Time; nil means describe TIME in the local time zone.
1514 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1515 by text that describes the specified date and time in TIME:
1517 %Y is the year, %y within the century, %C the century.
1518 %G is the year corresponding to the ISO week, %g within the century.
1519 %m is the numeric month.
1520 %b and %h are the locale's abbreviated month name, %B the full name.
1521 %d is the day of the month, zero-padded, %e is blank-padded.
1522 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1523 %a is the locale's abbreviated name of the day of week, %A the full name.
1524 %U is the week number starting on Sunday, %W starting on Monday,
1525 %V according to ISO 8601.
1526 %j is the day of the year.
1528 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1529 only blank-padded, %l is like %I blank-padded.
1530 %p is the locale's equivalent of either AM or PM.
1533 %Z is the time zone name, %z is the numeric form.
1534 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1536 %c is the locale's date and time format.
1537 %x is the locale's "preferred" date format.
1538 %D is like "%m/%d/%y".
1540 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1541 %X is the locale's "preferred" time format.
1543 Finally, %n is a newline, %t is a tab, %% is a literal %.
1545 Certain flags and modifiers are available with some format controls.
1546 The flags are `_', `-', `^' and `#'. For certain characters X,
1547 %_X is like %X, but padded with blanks; %-X is like %X,
1548 but without padding. %^X is like %X, but with all textual
1549 characters up-cased; %#X is like %X, but with letter-case of
1550 all textual characters reversed.
1551 %NX (where N stands for an integer) is like %X,
1552 but takes up at least N (a number) positions.
1553 The modifiers are `E' and `O'. For certain characters X,
1554 %EX is a locale's alternative version of %X;
1555 %OX is like %X, but uses the locale's number symbols.
1557 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1558 (format_string
, time
, universal
)
1559 Lisp_Object format_string
, time
, universal
;
1564 int ut
= ! NILP (universal
);
1566 CHECK_STRING (format_string
);
1568 if (! lisp_time_argument (time
, &value
, NULL
))
1569 error ("Invalid time specification");
1571 format_string
= code_convert_string_norecord (format_string
,
1572 Vlocale_coding_system
, 1);
1574 /* This is probably enough. */
1575 size
= SBYTES (format_string
) * 6 + 50;
1577 tm
= ut
? gmtime (&value
) : localtime (&value
);
1579 error ("Specified time is not representable");
1581 synchronize_system_time_locale ();
1585 char *buf
= (char *) alloca (size
+ 1);
1589 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1590 SBYTES (format_string
),
1592 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1593 return code_convert_string_norecord (make_string (buf
, result
),
1594 Vlocale_coding_system
, 0);
1596 /* If buffer was too small, make it bigger and try again. */
1597 result
= emacs_memftimeu (NULL
, (size_t) -1,
1598 SDATA (format_string
),
1599 SBYTES (format_string
),
1605 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1606 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1607 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1608 as from `current-time' and `file-attributes', or `nil' to use the
1609 current time. The obsolete form (HIGH . LOW) is also still accepted.
1610 The list has the following nine members: SEC is an integer between 0
1611 and 60; SEC is 60 for a leap second, which only some operating systems
1612 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1613 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1614 integer between 1 and 12. YEAR is an integer indicating the
1615 four-digit year. DOW is the day of week, an integer between 0 and 6,
1616 where 0 is Sunday. DST is t if daylight savings time is effect,
1617 otherwise nil. ZONE is an integer indicating the number of seconds
1618 east of Greenwich. (Note that Common Lisp has different meanings for
1621 Lisp_Object specified_time
;
1625 struct tm
*decoded_time
;
1626 Lisp_Object list_args
[9];
1628 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1629 error ("Invalid time specification");
1631 decoded_time
= localtime (&time_spec
);
1633 error ("Specified time is not representable");
1634 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1635 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1636 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1637 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1638 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1639 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1640 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1641 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1643 /* Make a copy, in case gmtime modifies the struct. */
1644 save_tm
= *decoded_time
;
1645 decoded_time
= gmtime (&time_spec
);
1646 if (decoded_time
== 0)
1647 list_args
[8] = Qnil
;
1649 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1650 return Flist (9, list_args
);
1653 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1654 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1655 This is the reverse operation of `decode-time', which see.
1656 ZONE defaults to the current time zone rule. This can
1657 be a string or t (as from `set-time-zone-rule'), or it can be a list
1658 \(as from `current-time-zone') or an integer (as from `decode-time')
1659 applied without consideration for daylight savings time.
1661 You can pass more than 7 arguments; then the first six arguments
1662 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1663 The intervening arguments are ignored.
1664 This feature lets (apply 'encode-time (decode-time ...)) work.
1666 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1667 for example, a DAY of 0 means the day preceding the given month.
1668 Year numbers less than 100 are treated just like other year numbers.
1669 If you want them to stand for years in this century, you must do that yourself.
1671 Years before 1970 are not guaranteed to work. On some systems,
1672 year values as low as 1901 do work.
1674 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1677 register Lisp_Object
*args
;
1681 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1683 CHECK_NUMBER (args
[0]); /* second */
1684 CHECK_NUMBER (args
[1]); /* minute */
1685 CHECK_NUMBER (args
[2]); /* hour */
1686 CHECK_NUMBER (args
[3]); /* day */
1687 CHECK_NUMBER (args
[4]); /* month */
1688 CHECK_NUMBER (args
[5]); /* year */
1690 tm
.tm_sec
= XINT (args
[0]);
1691 tm
.tm_min
= XINT (args
[1]);
1692 tm
.tm_hour
= XINT (args
[2]);
1693 tm
.tm_mday
= XINT (args
[3]);
1694 tm
.tm_mon
= XINT (args
[4]) - 1;
1695 tm
.tm_year
= XINT (args
[5]) - 1900;
1701 time
= mktime (&tm
);
1706 char **oldenv
= environ
, **newenv
;
1710 else if (STRINGP (zone
))
1711 tzstring
= (char *) SDATA (zone
);
1712 else if (INTEGERP (zone
))
1714 int abszone
= abs (XINT (zone
));
1715 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1716 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1720 error ("Invalid time zone specification");
1722 /* Set TZ before calling mktime; merely adjusting mktime's returned
1723 value doesn't suffice, since that would mishandle leap seconds. */
1724 set_time_zone_rule (tzstring
);
1726 time
= mktime (&tm
);
1728 /* Restore TZ to previous value. */
1732 #ifdef LOCALTIME_CACHE
1737 if (time
== (time_t) -1)
1738 error ("Specified time is not representable");
1740 return make_time (time
);
1743 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1744 doc
: /* Return the current time, as a human-readable string.
1745 Programs can use this function to decode a time,
1746 since the number of columns in each field is fixed.
1747 The format is `Sun Sep 16 01:03:52 1973'.
1748 However, see also the functions `decode-time' and `format-time-string'
1749 which provide a much more powerful and general facility.
1751 If SPECIFIED-TIME is given, it is a time to format instead of the
1752 current time. The argument should have the form (HIGH LOW . IGNORED).
1753 Thus, you can use times obtained from `current-time' and from
1754 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1755 but this is considered obsolete. */)
1757 Lisp_Object specified_time
;
1763 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1765 tem
= (char *) ctime (&value
);
1767 strncpy (buf
, tem
, 24);
1770 return build_string (buf
);
1773 #define TM_YEAR_BASE 1900
1775 /* Yield A - B, measured in seconds.
1776 This function is copied from the GNU C Library. */
1781 /* Compute intervening leap days correctly even if year is negative.
1782 Take care to avoid int overflow in leap day calculations,
1783 but it's OK to assume that A and B are close to each other. */
1784 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1785 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1786 int a100
= a4
/ 25 - (a4
% 25 < 0);
1787 int b100
= b4
/ 25 - (b4
% 25 < 0);
1788 int a400
= a100
>> 2;
1789 int b400
= b100
>> 2;
1790 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1791 int years
= a
->tm_year
- b
->tm_year
;
1792 int days
= (365 * years
+ intervening_leap_days
1793 + (a
->tm_yday
- b
->tm_yday
));
1794 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1795 + (a
->tm_min
- b
->tm_min
))
1796 + (a
->tm_sec
- b
->tm_sec
));
1799 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1800 doc
: /* Return the offset and name for the local time zone.
1801 This returns a list of the form (OFFSET NAME).
1802 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1803 A negative value means west of Greenwich.
1804 NAME is a string giving the name of the time zone.
1805 If SPECIFIED-TIME is given, the time zone offset is determined from it
1806 instead of using the current time. The argument should have the form
1807 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1808 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1809 have the form (HIGH . LOW), but this is considered obsolete.
1811 Some operating systems cannot provide all this information to Emacs;
1812 in this case, `current-time-zone' returns a list containing nil for
1813 the data it can't find. */)
1815 Lisp_Object specified_time
;
1821 if (lisp_time_argument (specified_time
, &value
, NULL
)
1822 && (t
= gmtime (&value
)) != 0
1823 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1825 int offset
= tm_diff (t
, &gmt
);
1830 s
= (char *)t
->tm_zone
;
1831 #else /* not HAVE_TM_ZONE */
1833 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1834 s
= tzname
[t
->tm_isdst
];
1836 #endif /* not HAVE_TM_ZONE */
1838 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1841 /* On Japanese w32, we can get a Japanese string as time
1842 zone name. Don't accept that. */
1844 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1853 /* No local time zone name is available; use "+-NNNN" instead. */
1854 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1855 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1858 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1861 return Fmake_list (make_number (2), Qnil
);
1864 /* This holds the value of `environ' produced by the previous
1865 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1866 has never been called. */
1867 static char **environbuf
;
1869 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1870 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1871 If TZ is nil, use implementation-defined default time zone information.
1872 If TZ is t, use Universal Time. */)
1880 else if (EQ (tz
, Qt
))
1885 tzstring
= (char *) SDATA (tz
);
1888 set_time_zone_rule (tzstring
);
1891 environbuf
= environ
;
1896 #ifdef LOCALTIME_CACHE
1898 /* These two values are known to load tz files in buggy implementations,
1899 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1900 Their values shouldn't matter in non-buggy implementations.
1901 We don't use string literals for these strings,
1902 since if a string in the environment is in readonly
1903 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1904 See Sun bugs 1113095 and 1114114, ``Timezone routines
1905 improperly modify environment''. */
1907 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1908 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1912 /* Set the local time zone rule to TZSTRING.
1913 This allocates memory into `environ', which it is the caller's
1914 responsibility to free. */
1917 set_time_zone_rule (tzstring
)
1921 char **from
, **to
, **newenv
;
1923 /* Make the ENVIRON vector longer with room for TZSTRING. */
1924 for (from
= environ
; *from
; from
++)
1926 envptrs
= from
- environ
+ 2;
1927 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1928 + (tzstring
? strlen (tzstring
) + 4 : 0));
1930 /* Add TZSTRING to the end of environ, as a value for TZ. */
1933 char *t
= (char *) (to
+ envptrs
);
1935 strcat (t
, tzstring
);
1939 /* Copy the old environ vector elements into NEWENV,
1940 but don't copy the TZ variable.
1941 So we have only one definition of TZ, which came from TZSTRING. */
1942 for (from
= environ
; *from
; from
++)
1943 if (strncmp (*from
, "TZ=", 3) != 0)
1949 /* If we do have a TZSTRING, NEWENV points to the vector slot where
1950 the TZ variable is stored. If we do not have a TZSTRING,
1951 TO points to the vector slot which has the terminating null. */
1953 #ifdef LOCALTIME_CACHE
1955 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
1956 "US/Pacific" that loads a tz file, then changes to a value like
1957 "XXX0" that does not load a tz file, and then changes back to
1958 its original value, the last change is (incorrectly) ignored.
1959 Also, if TZ changes twice in succession to values that do
1960 not load a tz file, tzset can dump core (see Sun bug#1225179).
1961 The following code works around these bugs. */
1965 /* Temporarily set TZ to a value that loads a tz file
1966 and that differs from tzstring. */
1968 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
1969 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
1975 /* The implied tzstring is unknown, so temporarily set TZ to
1976 two different values that each load a tz file. */
1977 *to
= set_time_zone_rule_tz1
;
1980 *to
= set_time_zone_rule_tz2
;
1985 /* Now TZ has the desired value, and tzset can be invoked safely. */
1992 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
1993 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
1994 type of object is Lisp_String). INHERIT is passed to
1995 INSERT_FROM_STRING_FUNC as the last argument. */
1998 general_insert_function (insert_func
, insert_from_string_func
,
1999 inherit
, nargs
, args
)
2000 void (*insert_func
) P_ ((const unsigned char *, int));
2001 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2003 register Lisp_Object
*args
;
2005 register int argnum
;
2006 register Lisp_Object val
;
2008 for (argnum
= 0; argnum
< nargs
; argnum
++)
2014 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2017 if (!NILP (current_buffer
->enable_multibyte_characters
))
2018 len
= CHAR_STRING (XFASTINT (val
), str
);
2021 str
[0] = (SINGLE_BYTE_CHAR_P (XINT (val
))
2023 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2026 (*insert_func
) (str
, len
);
2028 else if (STRINGP (val
))
2030 (*insert_from_string_func
) (val
, 0, 0,
2037 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2051 /* Callers passing one argument to Finsert need not gcpro the
2052 argument "array", since the only element of the array will
2053 not be used after calling insert or insert_from_string, so
2054 we don't care if it gets trashed. */
2056 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2057 doc
: /* Insert the arguments, either strings or characters, at point.
2058 Point and before-insertion markers move forward to end up
2059 after the inserted text.
2060 Any other markers at the point of insertion remain before the text.
2062 If the current buffer is multibyte, unibyte strings are converted
2063 to multibyte for insertion (see `string-make-multibyte').
2064 If the current buffer is unibyte, multibyte strings are converted
2065 to unibyte for insertion (see `string-make-unibyte').
2067 When operating on binary data, it may be necessary to preserve the
2068 original bytes of a unibyte string when inserting it into a multibyte
2069 buffer; to accomplish this, apply `string-as-multibyte' to the string
2070 and insert the result.
2072 usage: (insert &rest ARGS) */)
2075 register Lisp_Object
*args
;
2077 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2081 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2083 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2084 Point and before-insertion markers move forward to end up
2085 after the inserted text.
2086 Any other markers at the point of insertion remain before the text.
2088 If the current buffer is multibyte, unibyte strings are converted
2089 to multibyte for insertion (see `unibyte-char-to-multibyte').
2090 If the current buffer is unibyte, multibyte strings are converted
2091 to unibyte for insertion.
2093 usage: (insert-and-inherit &rest ARGS) */)
2096 register Lisp_Object
*args
;
2098 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2103 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2104 doc
: /* Insert strings or characters at point, relocating markers after the text.
2105 Point and markers move forward to end up after the inserted text.
2107 If the current buffer is multibyte, unibyte strings are converted
2108 to multibyte for insertion (see `unibyte-char-to-multibyte').
2109 If the current buffer is unibyte, multibyte strings are converted
2110 to unibyte for insertion.
2112 usage: (insert-before-markers &rest ARGS) */)
2115 register Lisp_Object
*args
;
2117 general_insert_function (insert_before_markers
,
2118 insert_from_string_before_markers
, 0,
2123 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2124 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2125 doc
: /* Insert text at point, relocating markers and inheriting properties.
2126 Point and markers move forward to end up after the inserted text.
2128 If the current buffer is multibyte, unibyte strings are converted
2129 to multibyte for insertion (see `unibyte-char-to-multibyte').
2130 If the current buffer is unibyte, multibyte strings are converted
2131 to unibyte for insertion.
2133 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2136 register Lisp_Object
*args
;
2138 general_insert_function (insert_before_markers_and_inherit
,
2139 insert_from_string_before_markers
, 1,
2144 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2145 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2146 Both arguments are required.
2147 Point, and before-insertion markers, are relocated as in the function `insert'.
2148 The optional third arg INHERIT, if non-nil, says to inherit text properties
2149 from adjoining text, if those properties are sticky. */)
2150 (character
, count
, inherit
)
2151 Lisp_Object character
, count
, inherit
;
2153 register unsigned char *string
;
2154 register int strlen
;
2157 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2159 CHECK_NUMBER (character
);
2160 CHECK_NUMBER (count
);
2162 if (!NILP (current_buffer
->enable_multibyte_characters
))
2163 len
= CHAR_STRING (XFASTINT (character
), str
);
2165 str
[0] = XFASTINT (character
), len
= 1;
2166 n
= XINT (count
) * len
;
2169 strlen
= min (n
, 256 * len
);
2170 string
= (unsigned char *) alloca (strlen
);
2171 for (i
= 0; i
< strlen
; i
++)
2172 string
[i
] = str
[i
% len
];
2176 if (!NILP (inherit
))
2177 insert_and_inherit (string
, strlen
);
2179 insert (string
, strlen
);
2184 if (!NILP (inherit
))
2185 insert_and_inherit (string
, n
);
2193 /* Making strings from buffer contents. */
2195 /* Return a Lisp_String containing the text of the current buffer from
2196 START to END. If text properties are in use and the current buffer
2197 has properties in the range specified, the resulting string will also
2198 have them, if PROPS is nonzero.
2200 We don't want to use plain old make_string here, because it calls
2201 make_uninit_string, which can cause the buffer arena to be
2202 compacted. make_string has no way of knowing that the data has
2203 been moved, and thus copies the wrong data into the string. This
2204 doesn't effect most of the other users of make_string, so it should
2205 be left as is. But we should use this function when conjuring
2206 buffer substrings. */
2209 make_buffer_string (start
, end
, props
)
2213 int start_byte
= CHAR_TO_BYTE (start
);
2214 int end_byte
= CHAR_TO_BYTE (end
);
2216 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2219 /* Return a Lisp_String containing the text of the current buffer from
2220 START / START_BYTE to END / END_BYTE.
2222 If text properties are in use and the current buffer
2223 has properties in the range specified, the resulting string will also
2224 have them, if PROPS is nonzero.
2226 We don't want to use plain old make_string here, because it calls
2227 make_uninit_string, which can cause the buffer arena to be
2228 compacted. make_string has no way of knowing that the data has
2229 been moved, and thus copies the wrong data into the string. This
2230 doesn't effect most of the other users of make_string, so it should
2231 be left as is. But we should use this function when conjuring
2232 buffer substrings. */
2235 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2236 int start
, start_byte
, end
, end_byte
;
2239 Lisp_Object result
, tem
, tem1
;
2241 if (start
< GPT
&& GPT
< end
)
2244 if (! NILP (current_buffer
->enable_multibyte_characters
))
2245 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2247 result
= make_uninit_string (end
- start
);
2248 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2249 end_byte
- start_byte
);
2251 /* If desired, update and copy the text properties. */
2254 update_buffer_properties (start
, end
);
2256 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2257 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2259 if (XINT (tem
) != end
|| !NILP (tem1
))
2260 copy_intervals_to_string (result
, current_buffer
, start
,
2267 /* Call Vbuffer_access_fontify_functions for the range START ... END
2268 in the current buffer, if necessary. */
2271 update_buffer_properties (start
, end
)
2274 /* If this buffer has some access functions,
2275 call them, specifying the range of the buffer being accessed. */
2276 if (!NILP (Vbuffer_access_fontify_functions
))
2278 Lisp_Object args
[3];
2281 args
[0] = Qbuffer_access_fontify_functions
;
2282 XSETINT (args
[1], start
);
2283 XSETINT (args
[2], end
);
2285 /* But don't call them if we can tell that the work
2286 has already been done. */
2287 if (!NILP (Vbuffer_access_fontified_property
))
2289 tem
= Ftext_property_any (args
[1], args
[2],
2290 Vbuffer_access_fontified_property
,
2293 Frun_hook_with_args (3, args
);
2296 Frun_hook_with_args (3, args
);
2300 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2301 doc
: /* Return the contents of part of the current buffer as a string.
2302 The two arguments START and END are character positions;
2303 they can be in either order.
2304 The string returned is multibyte if the buffer is multibyte.
2306 This function copies the text properties of that part of the buffer
2307 into the result string; if you don't want the text properties,
2308 use `buffer-substring-no-properties' instead. */)
2310 Lisp_Object start
, end
;
2314 validate_region (&start
, &end
);
2318 return make_buffer_string (b
, e
, 1);
2321 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2322 Sbuffer_substring_no_properties
, 2, 2, 0,
2323 doc
: /* Return the characters of part of the buffer, without the text properties.
2324 The two arguments START and END are character positions;
2325 they can be in either order. */)
2327 Lisp_Object start
, end
;
2331 validate_region (&start
, &end
);
2335 return make_buffer_string (b
, e
, 0);
2338 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2339 doc
: /* Return the contents of the current buffer as a string.
2340 If narrowing is in effect, this function returns only the visible part
2344 return make_buffer_string (BEGV
, ZV
, 1);
2347 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2349 doc
: /* Insert before point a substring of the contents of BUFFER.
2350 BUFFER may be a buffer or a buffer name.
2351 Arguments START and END are character positions specifying the substring.
2352 They default to the values of (point-min) and (point-max) in BUFFER. */)
2353 (buffer
, start
, end
)
2354 Lisp_Object buffer
, start
, end
;
2356 register int b
, e
, temp
;
2357 register struct buffer
*bp
, *obuf
;
2360 buf
= Fget_buffer (buffer
);
2364 if (NILP (bp
->name
))
2365 error ("Selecting deleted buffer");
2371 CHECK_NUMBER_COERCE_MARKER (start
);
2378 CHECK_NUMBER_COERCE_MARKER (end
);
2383 temp
= b
, b
= e
, e
= temp
;
2385 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2386 args_out_of_range (start
, end
);
2388 obuf
= current_buffer
;
2389 set_buffer_internal_1 (bp
);
2390 update_buffer_properties (b
, e
);
2391 set_buffer_internal_1 (obuf
);
2393 insert_from_buffer (bp
, b
, e
- b
, 0);
2397 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2399 doc
: /* Compare two substrings of two buffers; return result as number.
2400 the value is -N if first string is less after N-1 chars,
2401 +N if first string is greater after N-1 chars, or 0 if strings match.
2402 Each substring is represented as three arguments: BUFFER, START and END.
2403 That makes six args in all, three for each substring.
2405 The value of `case-fold-search' in the current buffer
2406 determines whether case is significant or ignored. */)
2407 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2408 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2410 register int begp1
, endp1
, begp2
, endp2
, temp
;
2411 register struct buffer
*bp1
, *bp2
;
2412 register Lisp_Object
*trt
2413 = (!NILP (current_buffer
->case_fold_search
)
2414 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2416 int i1
, i2
, i1_byte
, i2_byte
;
2418 /* Find the first buffer and its substring. */
2421 bp1
= current_buffer
;
2425 buf1
= Fget_buffer (buffer1
);
2428 bp1
= XBUFFER (buf1
);
2429 if (NILP (bp1
->name
))
2430 error ("Selecting deleted buffer");
2434 begp1
= BUF_BEGV (bp1
);
2437 CHECK_NUMBER_COERCE_MARKER (start1
);
2438 begp1
= XINT (start1
);
2441 endp1
= BUF_ZV (bp1
);
2444 CHECK_NUMBER_COERCE_MARKER (end1
);
2445 endp1
= XINT (end1
);
2449 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2451 if (!(BUF_BEGV (bp1
) <= begp1
2453 && endp1
<= BUF_ZV (bp1
)))
2454 args_out_of_range (start1
, end1
);
2456 /* Likewise for second substring. */
2459 bp2
= current_buffer
;
2463 buf2
= Fget_buffer (buffer2
);
2466 bp2
= XBUFFER (buf2
);
2467 if (NILP (bp2
->name
))
2468 error ("Selecting deleted buffer");
2472 begp2
= BUF_BEGV (bp2
);
2475 CHECK_NUMBER_COERCE_MARKER (start2
);
2476 begp2
= XINT (start2
);
2479 endp2
= BUF_ZV (bp2
);
2482 CHECK_NUMBER_COERCE_MARKER (end2
);
2483 endp2
= XINT (end2
);
2487 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2489 if (!(BUF_BEGV (bp2
) <= begp2
2491 && endp2
<= BUF_ZV (bp2
)))
2492 args_out_of_range (start2
, end2
);
2496 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2497 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2499 while (i1
< endp1
&& i2
< endp2
)
2501 /* When we find a mismatch, we must compare the
2502 characters, not just the bytes. */
2507 if (! NILP (bp1
->enable_multibyte_characters
))
2509 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2510 BUF_INC_POS (bp1
, i1_byte
);
2515 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2516 c1
= unibyte_char_to_multibyte (c1
);
2520 if (! NILP (bp2
->enable_multibyte_characters
))
2522 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2523 BUF_INC_POS (bp2
, i2_byte
);
2528 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2529 c2
= unibyte_char_to_multibyte (c2
);
2535 c1
= XINT (trt
[c1
]);
2536 c2
= XINT (trt
[c2
]);
2539 return make_number (- 1 - chars
);
2541 return make_number (chars
+ 1);
2546 /* The strings match as far as they go.
2547 If one is shorter, that one is less. */
2548 if (chars
< endp1
- begp1
)
2549 return make_number (chars
+ 1);
2550 else if (chars
< endp2
- begp2
)
2551 return make_number (- chars
- 1);
2553 /* Same length too => they are equal. */
2554 return make_number (0);
2558 subst_char_in_region_unwind (arg
)
2561 return current_buffer
->undo_list
= arg
;
2565 subst_char_in_region_unwind_1 (arg
)
2568 return current_buffer
->filename
= arg
;
2571 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2572 Ssubst_char_in_region
, 4, 5, 0,
2573 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2574 If optional arg NOUNDO is non-nil, don't record this change for undo
2575 and don't mark the buffer as really changed.
2576 Both characters must have the same length of multi-byte form. */)
2577 (start
, end
, fromchar
, tochar
, noundo
)
2578 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2580 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2582 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2584 int count
= SPECPDL_INDEX ();
2585 #define COMBINING_NO 0
2586 #define COMBINING_BEFORE 1
2587 #define COMBINING_AFTER 2
2588 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2589 int maybe_byte_combining
= COMBINING_NO
;
2590 int last_changed
= 0;
2591 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2593 validate_region (&start
, &end
);
2594 CHECK_NUMBER (fromchar
);
2595 CHECK_NUMBER (tochar
);
2599 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2600 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2601 error ("Characters in subst-char-in-region have different byte-lengths");
2602 if (!ASCII_BYTE_P (*tostr
))
2604 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2605 complete multibyte character, it may be combined with the
2606 after bytes. If it is in the range 0xA0..0xFF, it may be
2607 combined with the before and after bytes. */
2608 if (!CHAR_HEAD_P (*tostr
))
2609 maybe_byte_combining
= COMBINING_BOTH
;
2610 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2611 maybe_byte_combining
= COMBINING_AFTER
;
2617 fromstr
[0] = XFASTINT (fromchar
);
2618 tostr
[0] = XFASTINT (tochar
);
2622 pos_byte
= CHAR_TO_BYTE (pos
);
2623 stop
= CHAR_TO_BYTE (XINT (end
));
2626 /* If we don't want undo, turn off putting stuff on the list.
2627 That's faster than getting rid of things,
2628 and it prevents even the entry for a first change.
2629 Also inhibit locking the file. */
2632 record_unwind_protect (subst_char_in_region_unwind
,
2633 current_buffer
->undo_list
);
2634 current_buffer
->undo_list
= Qt
;
2635 /* Don't do file-locking. */
2636 record_unwind_protect (subst_char_in_region_unwind_1
,
2637 current_buffer
->filename
);
2638 current_buffer
->filename
= Qnil
;
2641 if (pos_byte
< GPT_BYTE
)
2642 stop
= min (stop
, GPT_BYTE
);
2645 int pos_byte_next
= pos_byte
;
2647 if (pos_byte
>= stop
)
2649 if (pos_byte
>= end_byte
) break;
2652 p
= BYTE_POS_ADDR (pos_byte
);
2654 INC_POS (pos_byte_next
);
2657 if (pos_byte_next
- pos_byte
== len
2658 && p
[0] == fromstr
[0]
2660 || (p
[1] == fromstr
[1]
2661 && (len
== 2 || (p
[2] == fromstr
[2]
2662 && (len
== 3 || p
[3] == fromstr
[3]))))))
2667 modify_region (current_buffer
, changed
, XINT (end
));
2669 if (! NILP (noundo
))
2671 if (MODIFF
- 1 == SAVE_MODIFF
)
2673 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2674 current_buffer
->auto_save_modified
++;
2678 /* Take care of the case where the new character
2679 combines with neighboring bytes. */
2680 if (maybe_byte_combining
2681 && (maybe_byte_combining
== COMBINING_AFTER
2682 ? (pos_byte_next
< Z_BYTE
2683 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2684 : ((pos_byte_next
< Z_BYTE
2685 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2686 || (pos_byte
> BEG_BYTE
2687 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2689 Lisp_Object tem
, string
;
2691 struct gcpro gcpro1
;
2693 tem
= current_buffer
->undo_list
;
2696 /* Make a multibyte string containing this single character. */
2697 string
= make_multibyte_string (tostr
, 1, len
);
2698 /* replace_range is less efficient, because it moves the gap,
2699 but it handles combining correctly. */
2700 replace_range (pos
, pos
+ 1, string
,
2702 pos_byte_next
= CHAR_TO_BYTE (pos
);
2703 if (pos_byte_next
> pos_byte
)
2704 /* Before combining happened. We should not increment
2705 POS. So, to cancel the later increment of POS,
2709 INC_POS (pos_byte_next
);
2711 if (! NILP (noundo
))
2712 current_buffer
->undo_list
= tem
;
2719 record_change (pos
, 1);
2720 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2722 last_changed
= pos
+ 1;
2724 pos_byte
= pos_byte_next
;
2730 signal_after_change (changed
,
2731 last_changed
- changed
, last_changed
- changed
);
2732 update_compositions (changed
, last_changed
, CHECK_ALL
);
2735 unbind_to (count
, Qnil
);
2739 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
2740 doc
: /* From START to END, translate characters according to TABLE.
2741 TABLE is a string; the Nth character in it is the mapping
2742 for the character with code N.
2743 It returns the number of characters changed. */)
2747 register Lisp_Object table
;
2749 register unsigned char *tt
; /* Trans table. */
2750 register int nc
; /* New character. */
2751 int cnt
; /* Number of changes made. */
2752 int size
; /* Size of translate table. */
2754 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2755 int string_multibyte
;
2757 validate_region (&start
, &end
);
2758 CHECK_STRING (table
);
2760 if (multibyte
!= (SCHARS (table
) < SBYTES (table
)))
2762 ? string_make_multibyte (table
)
2763 : string_make_unibyte (table
));
2764 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2766 size
= SCHARS (table
);
2770 pos_byte
= CHAR_TO_BYTE (pos
);
2771 modify_region (current_buffer
, pos
, XINT (end
));
2774 for (; pos
< XINT (end
); )
2776 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2782 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2787 if (string_multibyte
)
2789 str
= tt
+ string_char_to_byte (table
, oc
);
2790 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
, str_len
);
2795 nc
= tt
[oc
], str_len
= 1;
2803 /* This is less efficient, because it moves the gap,
2804 but it should multibyte characters correctly. */
2805 string
= make_multibyte_string (str
, 1, str_len
);
2806 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
2811 record_change (pos
, 1);
2812 while (str_len
-- > 0)
2814 signal_after_change (pos
, 1, 1);
2815 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
2824 return make_number (cnt
);
2827 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
2828 doc
: /* Delete the text between point and mark.
2830 When called from a program, expects two arguments,
2831 positions (integers or markers) specifying the stretch to be deleted. */)
2833 Lisp_Object start
, end
;
2835 validate_region (&start
, &end
);
2836 del_range (XINT (start
), XINT (end
));
2840 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
2841 Sdelete_and_extract_region
, 2, 2, 0,
2842 doc
: /* Delete the text between START and END and return it. */)
2844 Lisp_Object start
, end
;
2846 validate_region (&start
, &end
);
2847 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2850 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2851 doc
: /* Remove restrictions (narrowing) from current buffer.
2852 This allows the buffer's full text to be seen and edited. */)
2855 if (BEG
!= BEGV
|| Z
!= ZV
)
2856 current_buffer
->clip_changed
= 1;
2858 BEGV_BYTE
= BEG_BYTE
;
2859 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2860 /* Changing the buffer bounds invalidates any recorded current column. */
2861 invalidate_current_column ();
2865 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2866 doc
: /* Restrict editing in this buffer to the current region.
2867 The rest of the text becomes temporarily invisible and untouchable
2868 but is not deleted; if you save the buffer in a file, the invisible
2869 text is included in the file. \\[widen] makes all visible again.
2870 See also `save-restriction'.
2872 When calling from a program, pass two arguments; positions (integers
2873 or markers) bounding the text that should remain visible. */)
2875 register Lisp_Object start
, end
;
2877 CHECK_NUMBER_COERCE_MARKER (start
);
2878 CHECK_NUMBER_COERCE_MARKER (end
);
2880 if (XINT (start
) > XINT (end
))
2883 tem
= start
; start
= end
; end
= tem
;
2886 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2887 args_out_of_range (start
, end
);
2889 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2890 current_buffer
->clip_changed
= 1;
2892 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2893 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
2894 if (PT
< XFASTINT (start
))
2895 SET_PT (XFASTINT (start
));
2896 if (PT
> XFASTINT (end
))
2897 SET_PT (XFASTINT (end
));
2898 /* Changing the buffer bounds invalidates any recorded current column. */
2899 invalidate_current_column ();
2904 save_restriction_save ()
2906 if (BEGV
== BEG
&& ZV
== Z
)
2907 /* The common case that the buffer isn't narrowed.
2908 We return just the buffer object, which save_restriction_restore
2909 recognizes as meaning `no restriction'. */
2910 return Fcurrent_buffer ();
2912 /* We have to save a restriction, so return a pair of markers, one
2913 for the beginning and one for the end. */
2915 Lisp_Object beg
, end
;
2917 beg
= buildmark (BEGV
, BEGV_BYTE
);
2918 end
= buildmark (ZV
, ZV_BYTE
);
2920 /* END must move forward if text is inserted at its exact location. */
2921 XMARKER(end
)->insertion_type
= 1;
2923 return Fcons (beg
, end
);
2928 save_restriction_restore (data
)
2932 /* A pair of marks bounding a saved restriction. */
2934 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
2935 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
2936 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
2938 if (buf
/* Verify marker still points to a buffer. */
2939 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
2940 /* The restriction has changed from the saved one, so restore
2941 the saved restriction. */
2943 int pt
= BUF_PT (buf
);
2945 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
2946 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
2948 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
2949 /* The point is outside the new visible range, move it inside. */
2950 SET_BUF_PT_BOTH (buf
,
2951 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
2952 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
2955 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
2959 /* A buffer, which means that there was no old restriction. */
2961 struct buffer
*buf
= XBUFFER (data
);
2963 if (buf
/* Verify marker still points to a buffer. */
2964 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
2965 /* The buffer has been narrowed, get rid of the narrowing. */
2967 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
2968 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
2970 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
2977 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2978 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
2979 The buffer's restrictions make parts of the beginning and end invisible.
2980 (They are set up with `narrow-to-region' and eliminated with `widen'.)
2981 This special form, `save-restriction', saves the current buffer's restrictions
2982 when it is entered, and restores them when it is exited.
2983 So any `narrow-to-region' within BODY lasts only until the end of the form.
2984 The old restrictions settings are restored
2985 even in case of abnormal exit (throw or error).
2987 The value returned is the value of the last form in BODY.
2989 Note: if you are using both `save-excursion' and `save-restriction',
2990 use `save-excursion' outermost:
2991 (save-excursion (save-restriction ...))
2993 usage: (save-restriction &rest BODY) */)
2997 register Lisp_Object val
;
2998 int count
= SPECPDL_INDEX ();
3000 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3001 val
= Fprogn (body
);
3002 return unbind_to (count
, val
);
3005 /* Buffer for the most recent text displayed by Fmessage_box. */
3006 static char *message_text
;
3008 /* Allocated length of that buffer. */
3009 static int message_length
;
3011 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3012 doc
: /* Print a one-line message at the bottom of the screen.
3013 The first argument is a format control string, and the rest are data
3014 to be formatted under control of the string. See `format' for details.
3016 If the first argument is nil, clear any existing message; let the
3017 minibuffer contents show.
3019 usage: (message STRING &rest ARGS) */)
3025 || (STRINGP (args
[0])
3026 && SBYTES (args
[0]) == 0))
3033 register Lisp_Object val
;
3034 val
= Fformat (nargs
, args
);
3035 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3040 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3041 doc
: /* Display a message, in a dialog box if possible.
3042 If a dialog box is not available, use the echo area.
3043 The first argument is a format control string, and the rest are data
3044 to be formatted under control of the string. See `format' for details.
3046 If the first argument is nil, clear any existing message; let the
3047 minibuffer contents show.
3049 usage: (message-box STRING &rest ARGS) */)
3061 register Lisp_Object val
;
3062 val
= Fformat (nargs
, args
);
3064 /* The MS-DOS frames support popup menus even though they are
3065 not FRAME_WINDOW_P. */
3066 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3067 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3069 Lisp_Object pane
, menu
, obj
;
3070 struct gcpro gcpro1
;
3071 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3073 menu
= Fcons (val
, pane
);
3074 obj
= Fx_popup_dialog (Qt
, menu
);
3078 #endif /* HAVE_MENUS */
3079 /* Copy the data so that it won't move when we GC. */
3082 message_text
= (char *)xmalloc (80);
3083 message_length
= 80;
3085 if (SBYTES (val
) > message_length
)
3087 message_length
= SBYTES (val
);
3088 message_text
= (char *)xrealloc (message_text
, message_length
);
3090 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3091 message2 (message_text
, SBYTES (val
),
3092 STRING_MULTIBYTE (val
));
3097 extern Lisp_Object last_nonmenu_event
;
3100 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3101 doc
: /* Display a message in a dialog box or in the echo area.
3102 If this command was invoked with the mouse, use a dialog box if
3103 `use-dialog-box' is non-nil.
3104 Otherwise, use the echo area.
3105 The first argument is a format control string, and the rest are data
3106 to be formatted under control of the string. See `format' for details.
3108 If the first argument is nil, clear any existing message; let the
3109 minibuffer contents show.
3111 usage: (message-or-box STRING &rest ARGS) */)
3117 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3119 return Fmessage_box (nargs
, args
);
3121 return Fmessage (nargs
, args
);
3124 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3125 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3128 return current_message ();
3132 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3133 doc
: /* Return a copy of STRING with text properties added.
3134 First argument is the string to copy.
3135 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3136 properties to add to the result.
3137 usage: (propertize STRING &rest PROPERTIES) */)
3142 Lisp_Object properties
, string
;
3143 struct gcpro gcpro1
, gcpro2
;
3146 /* Number of args must be odd. */
3147 if ((nargs
& 1) == 0 || nargs
< 1)
3148 error ("Wrong number of arguments");
3150 properties
= string
= Qnil
;
3151 GCPRO2 (properties
, string
);
3153 /* First argument must be a string. */
3154 CHECK_STRING (args
[0]);
3155 string
= Fcopy_sequence (args
[0]);
3157 for (i
= 1; i
< nargs
; i
+= 2)
3159 CHECK_SYMBOL (args
[i
]);
3160 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3163 Fadd_text_properties (make_number (0),
3164 make_number (SCHARS (string
)),
3165 properties
, string
);
3166 RETURN_UNGCPRO (string
);
3170 /* Number of bytes that STRING will occupy when put into the result.
3171 MULTIBYTE is nonzero if the result should be multibyte. */
3173 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3174 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3175 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3178 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3179 doc
: /* Format a string out of a control-string and arguments.
3180 The first argument is a control string.
3181 The other arguments are substituted into it to make the result, a string.
3182 It may contain %-sequences meaning to substitute the next argument.
3183 %s means print a string argument. Actually, prints any object, with `princ'.
3184 %d means print as number in decimal (%o octal, %x hex).
3185 %X is like %x, but uses upper case.
3186 %e means print a number in exponential notation.
3187 %f means print a number in decimal-point notation.
3188 %g means print a number in exponential notation
3189 or decimal-point notation, whichever uses fewer characters.
3190 %c means print a number as a single character.
3191 %S means print any object as an s-expression (using `prin1').
3192 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3193 Use %% to put a single % into the output.
3195 The basic structure of a %-sequence is
3196 % <flags> <width> <precision> character
3197 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3199 usage: (format STRING &rest OBJECTS) */)
3202 register Lisp_Object
*args
;
3204 register int n
; /* The number of the next arg to substitute */
3205 register int total
; /* An estimate of the final length */
3207 register unsigned char *format
, *end
, *format_start
;
3209 /* Nonzero if the output should be a multibyte string,
3210 which is true if any of the inputs is one. */
3212 /* When we make a multibyte string, we must pay attention to the
3213 byte combining problem, i.e., a byte may be combined with a
3214 multibyte charcter of the previous string. This flag tells if we
3215 must consider such a situation or not. */
3216 int maybe_combine_byte
;
3217 unsigned char *this_format
;
3218 /* Precision for each spec, or -1, a flag value meaning no precision
3219 was given in that spec. Element 0, corresonding to the format
3220 string itself, will not be used. Element NARGS, corresponding to
3221 no argument, *will* be assigned to in the case that a `%' and `.'
3222 occur after the final format specifier. */
3223 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3226 int arg_intervals
= 0;
3229 /* discarded[I] is 1 if byte I of the format
3230 string was not copied into the output.
3231 It is 2 if byte I was not the first byte of its character. */
3234 /* Each element records, for one argument,
3235 the start and end bytepos in the output string,
3236 and whether the argument is a string with intervals.
3237 info[0] is unused. Unused elements have -1 for start. */
3240 int start
, end
, intervals
;
3243 /* It should not be necessary to GCPRO ARGS, because
3244 the caller in the interpreter should take care of that. */
3246 /* Try to determine whether the result should be multibyte.
3247 This is not always right; sometimes the result needs to be multibyte
3248 because of an object that we will pass through prin1,
3249 and in that case, we won't know it here. */
3250 for (n
= 0; n
< nargs
; n
++)
3252 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3254 /* Piggyback on this loop to initialize precision[N]. */
3258 CHECK_STRING (args
[0]);
3259 /* We may have to change "%S" to "%s". */
3260 args
[0] = Fcopy_sequence (args
[0]);
3262 /* GC should never happen here, so abort if it does. */
3265 /* If we start out planning a unibyte result,
3266 then discover it has to be multibyte, we jump back to retry.
3267 That can only happen from the first large while loop below. */
3270 format
= SDATA (args
[0]);
3271 format_start
= format
;
3272 end
= format
+ SBYTES (args
[0]);
3275 /* Make room in result for all the non-%-codes in the control string. */
3276 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3278 /* Allocate the info and discarded tables. */
3280 int nbytes
= nargs
* sizeof *info
;
3282 info
= (struct info
*) alloca (nbytes
);
3283 bzero (info
, nbytes
);
3284 for (i
= 0; i
< nargs
; i
++)
3286 discarded
= (char *) alloca (SBYTES (args
[0]));
3287 bzero (discarded
, SBYTES (args
[0]));
3290 /* Add to TOTAL enough space to hold the converted arguments. */
3293 while (format
!= end
)
3294 if (*format
++ == '%')
3297 int actual_width
= 0;
3298 unsigned char *this_format_start
= format
- 1;
3299 int field_width
= 0;
3301 /* General format specifications look like
3303 '%' [flags] [field-width] [precision] format
3308 field-width ::= [0-9]+
3309 precision ::= '.' [0-9]*
3311 If a field-width is specified, it specifies to which width
3312 the output should be padded with blanks, iff the output
3313 string is shorter than field-width.
3315 If precision is specified, it specifies the number of
3316 digits to print after the '.' for floats, or the max.
3317 number of chars to print from a string. */
3319 while (index ("-0# ", *format
))
3322 if (*format
>= '0' && *format
<= '9')
3324 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3325 field_width
= 10 * field_width
+ *format
- '0';
3328 /* N is not incremented for another few lines below, so refer to
3329 element N+1 (which might be precision[NARGS]). */
3333 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3334 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3337 if (format
- this_format_start
+ 1 > longest_format
)
3338 longest_format
= format
- this_format_start
+ 1;
3341 error ("Format string ends in middle of format specifier");
3344 else if (++n
>= nargs
)
3345 error ("Not enough arguments for format string");
3346 else if (*format
== 'S')
3348 /* For `S', prin1 the argument and then treat like a string. */
3349 register Lisp_Object tem
;
3350 tem
= Fprin1_to_string (args
[n
], Qnil
);
3351 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3357 /* If we restart the loop, we should not come here again
3358 because args[n] is now a string and calling
3359 Fprin1_to_string on it produces superflous double
3360 quotes. So, change "%S" to "%s" now. */
3364 else if (SYMBOLP (args
[n
]))
3366 args
[n
] = SYMBOL_NAME (args
[n
]);
3367 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3374 else if (STRINGP (args
[n
]))
3377 if (*format
!= 's' && *format
!= 'S')
3378 error ("Format specifier doesn't match argument type");
3379 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3380 to be as large as is calculated here. Easy check for
3381 the case PRECISION = 0. */
3382 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3383 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3385 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3386 else if (INTEGERP (args
[n
]) && *format
!= 's')
3388 /* The following loop assumes the Lisp type indicates
3389 the proper way to pass the argument.
3390 So make sure we have a flonum if the argument should
3392 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3393 args
[n
] = Ffloat (args
[n
]);
3395 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3396 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3397 error ("Invalid format operation %%%c", *format
);
3402 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3403 /* Note: No one can remember why we have to treat
3404 the character 0 as a multibyte character here.
3405 But, until it causes a real problem, let's
3407 || XINT (args
[n
]) == 0)
3414 args
[n
] = Fchar_to_string (args
[n
]);
3415 thissize
= SBYTES (args
[n
]);
3417 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3420 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3421 thissize
= SBYTES (args
[n
]);
3425 else if (FLOATP (args
[n
]) && *format
!= 's')
3427 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3429 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3430 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3431 error ("Invalid format operation %%%c", *format
);
3432 args
[n
] = Ftruncate (args
[n
], Qnil
);
3435 /* Note that we're using sprintf to print floats,
3436 so we have to take into account what that function
3438 /* Filter out flag value of -1. */
3439 thissize
= (MAX_10_EXP
+ 100
3440 + (precision
[n
] > 0 ? precision
[n
] : 0));
3444 /* Anything but a string, convert to a string using princ. */
3445 register Lisp_Object tem
;
3446 tem
= Fprin1_to_string (args
[n
], Qt
);
3447 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3456 thissize
+= max (0, field_width
- actual_width
);
3457 total
+= thissize
+ 4;
3462 /* Now we can no longer jump to retry.
3463 TOTAL and LONGEST_FORMAT are known for certain. */
3465 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3467 /* Allocate the space for the result.
3468 Note that TOTAL is an overestimate. */
3469 SAFE_ALLOCA (buf
, char *, total
);
3475 /* Scan the format and store result in BUF. */
3476 format
= SDATA (args
[0]);
3477 format_start
= format
;
3478 end
= format
+ SBYTES (args
[0]);
3479 maybe_combine_byte
= 0;
3480 while (format
!= end
)
3486 unsigned char *this_format_start
= format
;
3488 discarded
[format
- format_start
] = 1;
3491 while (index("-0# ", *format
))
3497 discarded
[format
- format_start
] = 1;
3501 minlen
= atoi (format
);
3503 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3505 discarded
[format
- format_start
] = 1;
3509 if (*format
++ == '%')
3518 discarded
[format
- format_start
- 1] = 1;
3519 info
[n
].start
= nchars
;
3521 if (STRINGP (args
[n
]))
3523 /* handle case (precision[n] >= 0) */
3526 int nbytes
, start
, end
;
3529 /* lisp_string_width ignores a precision of 0, but GNU
3530 libc functions print 0 characters when the precision
3531 is 0. Imitate libc behavior here. Changing
3532 lisp_string_width is the right thing, and will be
3533 done, but meanwhile we work with it. */
3535 if (precision
[n
] == 0)
3536 width
= nchars_string
= nbytes
= 0;
3537 else if (precision
[n
] > 0)
3538 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3540 { /* no precision spec given for this argument */
3541 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3542 nbytes
= SBYTES (args
[n
]);
3543 nchars_string
= SCHARS (args
[n
]);
3546 /* If spec requires it, pad on right with spaces. */
3547 padding
= minlen
- width
;
3549 while (padding
-- > 0)
3556 nchars
+= nchars_string
;
3561 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3562 && STRING_MULTIBYTE (args
[n
])
3563 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3564 maybe_combine_byte
= 1;
3566 p
+= copy_text (SDATA (args
[n
]), p
,
3568 STRING_MULTIBYTE (args
[n
]), multibyte
);
3571 while (padding
-- > 0)
3577 /* If this argument has text properties, record where
3578 in the result string it appears. */
3579 if (STRING_INTERVALS (args
[n
]))
3580 info
[n
].intervals
= arg_intervals
= 1;
3582 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3586 bcopy (this_format_start
, this_format
,
3587 format
- this_format_start
);
3588 this_format
[format
- this_format_start
] = 0;
3590 if (INTEGERP (args
[n
]))
3591 sprintf (p
, this_format
, XINT (args
[n
]));
3593 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3597 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3598 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3599 maybe_combine_byte
= 1;
3600 this_nchars
= strlen (p
);
3602 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3605 nchars
+= this_nchars
;
3608 info
[n
].end
= nchars
;
3610 else if (STRING_MULTIBYTE (args
[0]))
3612 /* Copy a whole multibyte character. */
3615 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3616 && !CHAR_HEAD_P (*format
))
3617 maybe_combine_byte
= 1;
3619 while (! CHAR_HEAD_P (*format
))
3621 discarded
[format
- format_start
] = 2;
3628 /* Convert a single-byte character to multibyte. */
3629 int len
= copy_text (format
, p
, 1, 0, 1);
3636 *p
++ = *format
++, nchars
++;
3639 if (p
> buf
+ total
)
3642 if (maybe_combine_byte
)
3643 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3644 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3646 /* If we allocated BUF with malloc, free it too. */
3649 /* If the format string has text properties, or any of the string
3650 arguments has text properties, set up text properties of the
3653 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3655 Lisp_Object len
, new_len
, props
;
3656 struct gcpro gcpro1
;
3658 /* Add text properties from the format string. */
3659 len
= make_number (SCHARS (args
[0]));
3660 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3665 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3668 /* Adjust the bounds of each text property
3669 to the proper start and end in the output string. */
3670 /* We take advantage of the fact that the positions in PROPS
3671 are in increasing order, so that we can do (effectively)
3672 one scan through the position space of the format string.
3674 BYTEPOS is the byte position in the format string,
3675 POSITION is the untranslated char position in it,
3676 TRANSLATED is the translated char position in BUF,
3677 and ARGN is the number of the next arg we will come to. */
3678 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3685 /* First adjust the property start position. */
3686 pos
= XINT (XCAR (item
));
3688 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3689 up to this position. */
3690 for (; position
< pos
; bytepos
++)
3692 if (! discarded
[bytepos
])
3693 position
++, translated
++;
3694 else if (discarded
[bytepos
] == 1)
3697 if (translated
== info
[argn
].start
)
3699 translated
+= info
[argn
].end
- info
[argn
].start
;
3705 XSETCAR (item
, make_number (translated
));
3707 /* Likewise adjust the property end position. */
3708 pos
= XINT (XCAR (XCDR (item
)));
3710 for (; bytepos
< pos
; bytepos
++)
3712 if (! discarded
[bytepos
])
3713 position
++, translated
++;
3714 else if (discarded
[bytepos
] == 1)
3717 if (translated
== info
[argn
].start
)
3719 translated
+= info
[argn
].end
- info
[argn
].start
;
3725 XSETCAR (XCDR (item
), make_number (translated
));
3728 add_text_properties_from_list (val
, props
, make_number (0));
3731 /* Add text properties from arguments. */
3733 for (n
= 1; n
< nargs
; ++n
)
3734 if (info
[n
].intervals
)
3736 len
= make_number (SCHARS (args
[n
]));
3737 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3738 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3739 extend_property_ranges (props
, len
, new_len
);
3740 /* If successive arguments have properites, be sure that
3741 the value of `composition' property be the copy. */
3742 if (n
> 1 && info
[n
- 1].end
)
3743 make_composition_value_copy (props
);
3744 add_text_properties_from_list (val
, props
,
3745 make_number (info
[n
].start
));
3755 format2 (string1
, arg0
, arg1
)
3757 Lisp_Object arg0
, arg1
;
3759 Lisp_Object args
[3];
3760 args
[0] = build_string (string1
);
3763 return Fformat (3, args
);
3766 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3767 doc
: /* Return t if two characters match, optionally ignoring case.
3768 Both arguments must be characters (i.e. integers).
3769 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3771 register Lisp_Object c1
, c2
;
3777 if (XINT (c1
) == XINT (c2
))
3779 if (NILP (current_buffer
->case_fold_search
))
3782 /* Do these in separate statements,
3783 then compare the variables.
3784 because of the way DOWNCASE uses temp variables. */
3785 i1
= DOWNCASE (XFASTINT (c1
));
3786 i2
= DOWNCASE (XFASTINT (c2
));
3787 return (i1
== i2
? Qt
: Qnil
);
3790 /* Transpose the markers in two regions of the current buffer, and
3791 adjust the ones between them if necessary (i.e.: if the regions
3794 START1, END1 are the character positions of the first region.
3795 START1_BYTE, END1_BYTE are the byte positions.
3796 START2, END2 are the character positions of the second region.
3797 START2_BYTE, END2_BYTE are the byte positions.
3799 Traverses the entire marker list of the buffer to do so, adding an
3800 appropriate amount to some, subtracting from some, and leaving the
3801 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3803 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3806 transpose_markers (start1
, end1
, start2
, end2
,
3807 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3808 register int start1
, end1
, start2
, end2
;
3809 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3811 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3812 register struct Lisp_Marker
*marker
;
3814 /* Update point as if it were a marker. */
3818 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3819 PT_BYTE
+ (end2_byte
- end1_byte
));
3820 else if (PT
< start2
)
3821 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3822 (PT_BYTE
+ (end2_byte
- start2_byte
)
3823 - (end1_byte
- start1_byte
)));
3825 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3826 PT_BYTE
- (start2_byte
- start1_byte
));
3828 /* We used to adjust the endpoints here to account for the gap, but that
3829 isn't good enough. Even if we assume the caller has tried to move the
3830 gap out of our way, it might still be at start1 exactly, for example;
3831 and that places it `inside' the interval, for our purposes. The amount
3832 of adjustment is nontrivial if there's a `denormalized' marker whose
3833 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3834 the dirty work to Fmarker_position, below. */
3836 /* The difference between the region's lengths */
3837 diff
= (end2
- start2
) - (end1
- start1
);
3838 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3840 /* For shifting each marker in a region by the length of the other
3841 region plus the distance between the regions. */
3842 amt1
= (end2
- start2
) + (start2
- end1
);
3843 amt2
= (end1
- start1
) + (start2
- end1
);
3844 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3845 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3847 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
3849 mpos
= marker
->bytepos
;
3850 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3852 if (mpos
< end1_byte
)
3854 else if (mpos
< start2_byte
)
3858 marker
->bytepos
= mpos
;
3860 mpos
= marker
->charpos
;
3861 if (mpos
>= start1
&& mpos
< end2
)
3865 else if (mpos
< start2
)
3870 marker
->charpos
= mpos
;
3874 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
3875 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
3876 The regions may not be overlapping, because the size of the buffer is
3877 never changed in a transposition.
3879 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
3880 any markers that happen to be located in the regions.
3882 Transposing beyond buffer boundaries is an error. */)
3883 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
3884 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
3886 register int start1
, end1
, start2
, end2
;
3887 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
3888 int gap
, len1
, len_mid
, len2
;
3889 unsigned char *start1_addr
, *start2_addr
, *temp
;
3891 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
3892 cur_intv
= BUF_INTERVALS (current_buffer
);
3894 validate_region (&startr1
, &endr1
);
3895 validate_region (&startr2
, &endr2
);
3897 start1
= XFASTINT (startr1
);
3898 end1
= XFASTINT (endr1
);
3899 start2
= XFASTINT (startr2
);
3900 end2
= XFASTINT (endr2
);
3903 /* Swap the regions if they're reversed. */
3906 register int glumph
= start1
;
3914 len1
= end1
- start1
;
3915 len2
= end2
- start2
;
3918 error ("Transposed regions overlap");
3919 else if (start1
== end1
|| start2
== end2
)
3920 error ("Transposed region has length 0");
3922 /* The possibilities are:
3923 1. Adjacent (contiguous) regions, or separate but equal regions
3924 (no, really equal, in this case!), or
3925 2. Separate regions of unequal size.
3927 The worst case is usually No. 2. It means that (aside from
3928 potential need for getting the gap out of the way), there also
3929 needs to be a shifting of the text between the two regions. So
3930 if they are spread far apart, we are that much slower... sigh. */
3932 /* It must be pointed out that the really studly thing to do would
3933 be not to move the gap at all, but to leave it in place and work
3934 around it if necessary. This would be extremely efficient,
3935 especially considering that people are likely to do
3936 transpositions near where they are working interactively, which
3937 is exactly where the gap would be found. However, such code
3938 would be much harder to write and to read. So, if you are
3939 reading this comment and are feeling squirrely, by all means have
3940 a go! I just didn't feel like doing it, so I will simply move
3941 the gap the minimum distance to get it out of the way, and then
3942 deal with an unbroken array. */
3944 /* Make sure the gap won't interfere, by moving it out of the text
3945 we will operate on. */
3946 if (start1
< gap
&& gap
< end2
)
3948 if (gap
- start1
< end2
- gap
)
3954 start1_byte
= CHAR_TO_BYTE (start1
);
3955 start2_byte
= CHAR_TO_BYTE (start2
);
3956 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
3957 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
3959 #ifdef BYTE_COMBINING_DEBUG
3962 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
3963 len2_byte
, start1
, start1_byte
)
3964 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
3965 len1_byte
, end2
, start2_byte
+ len2_byte
)
3966 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
3967 len1_byte
, end2
, start2_byte
+ len2_byte
))
3972 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
3973 len2_byte
, start1
, start1_byte
)
3974 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
3975 len1_byte
, start2
, start2_byte
)
3976 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
3977 len2_byte
, end1
, start1_byte
+ len1_byte
)
3978 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
3979 len1_byte
, end2
, start2_byte
+ len2_byte
))
3984 /* Hmmm... how about checking to see if the gap is large
3985 enough to use as the temporary storage? That would avoid an
3986 allocation... interesting. Later, don't fool with it now. */
3988 /* Working without memmove, for portability (sigh), so must be
3989 careful of overlapping subsections of the array... */
3991 if (end1
== start2
) /* adjacent regions */
3993 modify_region (current_buffer
, start1
, end2
);
3994 record_change (start1
, len1
+ len2
);
3996 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
3997 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
3998 Fset_text_properties (make_number (start1
), make_number (end2
),
4001 /* First region smaller than second. */
4002 if (len1_byte
< len2_byte
)
4006 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4008 /* Don't precompute these addresses. We have to compute them
4009 at the last minute, because the relocating allocator might
4010 have moved the buffer around during the xmalloc. */
4011 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4012 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4014 bcopy (start2_addr
, temp
, len2_byte
);
4015 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4016 bcopy (temp
, start1_addr
, len2_byte
);
4017 SAFE_FREE (len2_byte
);
4020 /* First region not smaller than second. */
4024 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4025 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4026 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4027 bcopy (start1_addr
, temp
, len1_byte
);
4028 bcopy (start2_addr
, start1_addr
, len2_byte
);
4029 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4030 SAFE_FREE (len1_byte
);
4032 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4033 len1
, current_buffer
, 0);
4034 graft_intervals_into_buffer (tmp_interval2
, start1
,
4035 len2
, current_buffer
, 0);
4036 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4037 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4039 /* Non-adjacent regions, because end1 != start2, bleagh... */
4042 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4044 if (len1_byte
== len2_byte
)
4045 /* Regions are same size, though, how nice. */
4049 modify_region (current_buffer
, start1
, end1
);
4050 modify_region (current_buffer
, start2
, end2
);
4051 record_change (start1
, len1
);
4052 record_change (start2
, len2
);
4053 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4054 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4055 Fset_text_properties (make_number (start1
), make_number (end1
),
4057 Fset_text_properties (make_number (start2
), make_number (end2
),
4060 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4061 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4062 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4063 bcopy (start1_addr
, temp
, len1_byte
);
4064 bcopy (start2_addr
, start1_addr
, len2_byte
);
4065 bcopy (temp
, start2_addr
, len1_byte
);
4066 SAFE_FREE (len1_byte
);
4068 graft_intervals_into_buffer (tmp_interval1
, start2
,
4069 len1
, current_buffer
, 0);
4070 graft_intervals_into_buffer (tmp_interval2
, start1
,
4071 len2
, current_buffer
, 0);
4074 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4075 /* Non-adjacent & unequal size, area between must also be shifted. */
4079 modify_region (current_buffer
, start1
, end2
);
4080 record_change (start1
, (end2
- start1
));
4081 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4082 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4083 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4084 Fset_text_properties (make_number (start1
), make_number (end2
),
4087 /* holds region 2 */
4088 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4089 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4090 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4091 bcopy (start2_addr
, temp
, len2_byte
);
4092 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4093 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4094 bcopy (temp
, start1_addr
, len2_byte
);
4095 SAFE_FREE (len2_byte
);
4097 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4098 len1
, current_buffer
, 0);
4099 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4100 len_mid
, current_buffer
, 0);
4101 graft_intervals_into_buffer (tmp_interval2
, start1
,
4102 len2
, current_buffer
, 0);
4105 /* Second region smaller than first. */
4109 record_change (start1
, (end2
- start1
));
4110 modify_region (current_buffer
, start1
, end2
);
4112 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4113 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4114 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4115 Fset_text_properties (make_number (start1
), make_number (end2
),
4118 /* holds region 1 */
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 (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4125 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4126 SAFE_FREE (len1_byte
);
4128 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4129 len1
, current_buffer
, 0);
4130 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4131 len_mid
, current_buffer
, 0);
4132 graft_intervals_into_buffer (tmp_interval2
, start1
,
4133 len2
, current_buffer
, 0);
4136 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4137 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4140 /* When doing multiple transpositions, it might be nice
4141 to optimize this. Perhaps the markers in any one buffer
4142 should be organized in some sorted data tree. */
4143 if (NILP (leave_markers
))
4145 transpose_markers (start1
, end1
, start2
, end2
,
4146 start1_byte
, start1_byte
+ len1_byte
,
4147 start2_byte
, start2_byte
+ len2_byte
);
4148 fix_start_end_in_overlays (start1
, end2
);
4160 Qbuffer_access_fontify_functions
4161 = intern ("buffer-access-fontify-functions");
4162 staticpro (&Qbuffer_access_fontify_functions
);
4164 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4165 doc
: /* Non-nil means text motion commands don't notice fields. */);
4166 Vinhibit_field_text_motion
= Qnil
;
4168 DEFVAR_LISP ("buffer-access-fontify-functions",
4169 &Vbuffer_access_fontify_functions
,
4170 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4171 Each function is called with two arguments which specify the range
4172 of the buffer being accessed. */);
4173 Vbuffer_access_fontify_functions
= Qnil
;
4177 extern Lisp_Object Vprin1_to_string_buffer
;
4178 obuf
= Fcurrent_buffer ();
4179 /* Do this here, because init_buffer_once is too early--it won't work. */
4180 Fset_buffer (Vprin1_to_string_buffer
);
4181 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4182 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4187 DEFVAR_LISP ("buffer-access-fontified-property",
4188 &Vbuffer_access_fontified_property
,
4189 doc
: /* Property which (if non-nil) indicates text has been fontified.
4190 `buffer-substring' need not call the `buffer-access-fontify-functions'
4191 functions if all the text being accessed has this property. */);
4192 Vbuffer_access_fontified_property
= Qnil
;
4194 DEFVAR_LISP ("system-name", &Vsystem_name
,
4195 doc
: /* The name of the machine Emacs is running on. */);
4197 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4198 doc
: /* The full name of the user logged in. */);
4200 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4201 doc
: /* The user's name, taken from environment variables if possible. */);
4203 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4204 doc
: /* The user's name, based upon the real uid only. */);
4206 defsubr (&Spropertize
);
4207 defsubr (&Schar_equal
);
4208 defsubr (&Sgoto_char
);
4209 defsubr (&Sstring_to_char
);
4210 defsubr (&Schar_to_string
);
4211 defsubr (&Sbuffer_substring
);
4212 defsubr (&Sbuffer_substring_no_properties
);
4213 defsubr (&Sbuffer_string
);
4215 defsubr (&Spoint_marker
);
4216 defsubr (&Smark_marker
);
4218 defsubr (&Sregion_beginning
);
4219 defsubr (&Sregion_end
);
4221 staticpro (&Qfield
);
4222 Qfield
= intern ("field");
4223 staticpro (&Qboundary
);
4224 Qboundary
= intern ("boundary");
4225 defsubr (&Sfield_beginning
);
4226 defsubr (&Sfield_end
);
4227 defsubr (&Sfield_string
);
4228 defsubr (&Sfield_string_no_properties
);
4229 defsubr (&Sdelete_field
);
4230 defsubr (&Sconstrain_to_field
);
4232 defsubr (&Sline_beginning_position
);
4233 defsubr (&Sline_end_position
);
4235 /* defsubr (&Smark); */
4236 /* defsubr (&Sset_mark); */
4237 defsubr (&Ssave_excursion
);
4238 defsubr (&Ssave_current_buffer
);
4240 defsubr (&Sbufsize
);
4241 defsubr (&Spoint_max
);
4242 defsubr (&Spoint_min
);
4243 defsubr (&Spoint_min_marker
);
4244 defsubr (&Spoint_max_marker
);
4245 defsubr (&Sgap_position
);
4246 defsubr (&Sgap_size
);
4247 defsubr (&Sposition_bytes
);
4248 defsubr (&Sbyte_to_position
);
4254 defsubr (&Sfollowing_char
);
4255 defsubr (&Sprevious_char
);
4256 defsubr (&Schar_after
);
4257 defsubr (&Schar_before
);
4259 defsubr (&Sinsert_before_markers
);
4260 defsubr (&Sinsert_and_inherit
);
4261 defsubr (&Sinsert_and_inherit_before_markers
);
4262 defsubr (&Sinsert_char
);
4264 defsubr (&Suser_login_name
);
4265 defsubr (&Suser_real_login_name
);
4266 defsubr (&Suser_uid
);
4267 defsubr (&Suser_real_uid
);
4268 defsubr (&Suser_full_name
);
4269 defsubr (&Semacs_pid
);
4270 defsubr (&Scurrent_time
);
4271 defsubr (&Sformat_time_string
);
4272 defsubr (&Sfloat_time
);
4273 defsubr (&Sdecode_time
);
4274 defsubr (&Sencode_time
);
4275 defsubr (&Scurrent_time_string
);
4276 defsubr (&Scurrent_time_zone
);
4277 defsubr (&Sset_time_zone_rule
);
4278 defsubr (&Ssystem_name
);
4279 defsubr (&Smessage
);
4280 defsubr (&Smessage_box
);
4281 defsubr (&Smessage_or_box
);
4282 defsubr (&Scurrent_message
);
4285 defsubr (&Sinsert_buffer_substring
);
4286 defsubr (&Scompare_buffer_substrings
);
4287 defsubr (&Ssubst_char_in_region
);
4288 defsubr (&Stranslate_region
);
4289 defsubr (&Sdelete_region
);
4290 defsubr (&Sdelete_and_extract_region
);
4292 defsubr (&Snarrow_to_region
);
4293 defsubr (&Ssave_restriction
);
4294 defsubr (&Stranspose_regions
);
4297 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4298 (do not change this comment) */