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 if (XINT (start
) == XINT (end
))
2848 return build_string ("");
2849 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
2852 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
2853 doc
: /* Remove restrictions (narrowing) from current buffer.
2854 This allows the buffer's full text to be seen and edited. */)
2857 if (BEG
!= BEGV
|| Z
!= ZV
)
2858 current_buffer
->clip_changed
= 1;
2860 BEGV_BYTE
= BEG_BYTE
;
2861 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
2862 /* Changing the buffer bounds invalidates any recorded current column. */
2863 invalidate_current_column ();
2867 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
2868 doc
: /* Restrict editing in this buffer to the current region.
2869 The rest of the text becomes temporarily invisible and untouchable
2870 but is not deleted; if you save the buffer in a file, the invisible
2871 text is included in the file. \\[widen] makes all visible again.
2872 See also `save-restriction'.
2874 When calling from a program, pass two arguments; positions (integers
2875 or markers) bounding the text that should remain visible. */)
2877 register Lisp_Object start
, end
;
2879 CHECK_NUMBER_COERCE_MARKER (start
);
2880 CHECK_NUMBER_COERCE_MARKER (end
);
2882 if (XINT (start
) > XINT (end
))
2885 tem
= start
; start
= end
; end
= tem
;
2888 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
2889 args_out_of_range (start
, end
);
2891 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
2892 current_buffer
->clip_changed
= 1;
2894 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
2895 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
2896 if (PT
< XFASTINT (start
))
2897 SET_PT (XFASTINT (start
));
2898 if (PT
> XFASTINT (end
))
2899 SET_PT (XFASTINT (end
));
2900 /* Changing the buffer bounds invalidates any recorded current column. */
2901 invalidate_current_column ();
2906 save_restriction_save ()
2908 if (BEGV
== BEG
&& ZV
== Z
)
2909 /* The common case that the buffer isn't narrowed.
2910 We return just the buffer object, which save_restriction_restore
2911 recognizes as meaning `no restriction'. */
2912 return Fcurrent_buffer ();
2914 /* We have to save a restriction, so return a pair of markers, one
2915 for the beginning and one for the end. */
2917 Lisp_Object beg
, end
;
2919 beg
= buildmark (BEGV
, BEGV_BYTE
);
2920 end
= buildmark (ZV
, ZV_BYTE
);
2922 /* END must move forward if text is inserted at its exact location. */
2923 XMARKER(end
)->insertion_type
= 1;
2925 return Fcons (beg
, end
);
2930 save_restriction_restore (data
)
2934 /* A pair of marks bounding a saved restriction. */
2936 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
2937 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
2938 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
2940 if (buf
/* Verify marker still points to a buffer. */
2941 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
2942 /* The restriction has changed from the saved one, so restore
2943 the saved restriction. */
2945 int pt
= BUF_PT (buf
);
2947 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
2948 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
2950 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
2951 /* The point is outside the new visible range, move it inside. */
2952 SET_BUF_PT_BOTH (buf
,
2953 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
2954 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
2957 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
2961 /* A buffer, which means that there was no old restriction. */
2963 struct buffer
*buf
= XBUFFER (data
);
2965 if (buf
/* Verify marker still points to a buffer. */
2966 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
2967 /* The buffer has been narrowed, get rid of the narrowing. */
2969 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
2970 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
2972 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
2979 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
2980 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
2981 The buffer's restrictions make parts of the beginning and end invisible.
2982 (They are set up with `narrow-to-region' and eliminated with `widen'.)
2983 This special form, `save-restriction', saves the current buffer's restrictions
2984 when it is entered, and restores them when it is exited.
2985 So any `narrow-to-region' within BODY lasts only until the end of the form.
2986 The old restrictions settings are restored
2987 even in case of abnormal exit (throw or error).
2989 The value returned is the value of the last form in BODY.
2991 Note: if you are using both `save-excursion' and `save-restriction',
2992 use `save-excursion' outermost:
2993 (save-excursion (save-restriction ...))
2995 usage: (save-restriction &rest BODY) */)
2999 register Lisp_Object val
;
3000 int count
= SPECPDL_INDEX ();
3002 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3003 val
= Fprogn (body
);
3004 return unbind_to (count
, val
);
3007 /* Buffer for the most recent text displayed by Fmessage_box. */
3008 static char *message_text
;
3010 /* Allocated length of that buffer. */
3011 static int message_length
;
3013 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3014 doc
: /* Print a one-line message at the bottom of the screen.
3015 The first argument is a format control string, and the rest are data
3016 to be formatted under control of the string. See `format' for details.
3018 If the first argument is nil, clear any existing message; let the
3019 minibuffer contents show.
3021 usage: (message STRING &rest ARGS) */)
3027 || (STRINGP (args
[0])
3028 && SBYTES (args
[0]) == 0))
3035 register Lisp_Object val
;
3036 val
= Fformat (nargs
, args
);
3037 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3042 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3043 doc
: /* Display a message, in a dialog box if possible.
3044 If a dialog box is not available, use the echo area.
3045 The first argument is a format control string, and the rest are data
3046 to be formatted under control of the string. See `format' for details.
3048 If the first argument is nil, clear any existing message; let the
3049 minibuffer contents show.
3051 usage: (message-box STRING &rest ARGS) */)
3063 register Lisp_Object val
;
3064 val
= Fformat (nargs
, args
);
3066 /* The MS-DOS frames support popup menus even though they are
3067 not FRAME_WINDOW_P. */
3068 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3069 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3071 Lisp_Object pane
, menu
, obj
;
3072 struct gcpro gcpro1
;
3073 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3075 menu
= Fcons (val
, pane
);
3076 obj
= Fx_popup_dialog (Qt
, menu
);
3080 #endif /* HAVE_MENUS */
3081 /* Copy the data so that it won't move when we GC. */
3084 message_text
= (char *)xmalloc (80);
3085 message_length
= 80;
3087 if (SBYTES (val
) > message_length
)
3089 message_length
= SBYTES (val
);
3090 message_text
= (char *)xrealloc (message_text
, message_length
);
3092 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3093 message2 (message_text
, SBYTES (val
),
3094 STRING_MULTIBYTE (val
));
3099 extern Lisp_Object last_nonmenu_event
;
3102 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3103 doc
: /* Display a message in a dialog box or in the echo area.
3104 If this command was invoked with the mouse, use a dialog box if
3105 `use-dialog-box' is non-nil.
3106 Otherwise, use the echo area.
3107 The first argument is a format control string, and the rest are data
3108 to be formatted under control of the string. See `format' for details.
3110 If the first argument is nil, clear any existing message; let the
3111 minibuffer contents show.
3113 usage: (message-or-box STRING &rest ARGS) */)
3119 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3121 return Fmessage_box (nargs
, args
);
3123 return Fmessage (nargs
, args
);
3126 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3127 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3130 return current_message ();
3134 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3135 doc
: /* Return a copy of STRING with text properties added.
3136 First argument is the string to copy.
3137 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3138 properties to add to the result.
3139 usage: (propertize STRING &rest PROPERTIES) */)
3144 Lisp_Object properties
, string
;
3145 struct gcpro gcpro1
, gcpro2
;
3148 /* Number of args must be odd. */
3149 if ((nargs
& 1) == 0 || nargs
< 1)
3150 error ("Wrong number of arguments");
3152 properties
= string
= Qnil
;
3153 GCPRO2 (properties
, string
);
3155 /* First argument must be a string. */
3156 CHECK_STRING (args
[0]);
3157 string
= Fcopy_sequence (args
[0]);
3159 for (i
= 1; i
< nargs
; i
+= 2)
3161 CHECK_SYMBOL (args
[i
]);
3162 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3165 Fadd_text_properties (make_number (0),
3166 make_number (SCHARS (string
)),
3167 properties
, string
);
3168 RETURN_UNGCPRO (string
);
3172 /* Number of bytes that STRING will occupy when put into the result.
3173 MULTIBYTE is nonzero if the result should be multibyte. */
3175 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3176 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3177 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3180 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3181 doc
: /* Format a string out of a control-string and arguments.
3182 The first argument is a control string.
3183 The other arguments are substituted into it to make the result, a string.
3184 It may contain %-sequences meaning to substitute the next argument.
3185 %s means print a string argument. Actually, prints any object, with `princ'.
3186 %d means print as number in decimal (%o octal, %x hex).
3187 %X is like %x, but uses upper case.
3188 %e means print a number in exponential notation.
3189 %f means print a number in decimal-point notation.
3190 %g means print a number in exponential notation
3191 or decimal-point notation, whichever uses fewer characters.
3192 %c means print a number as a single character.
3193 %S means print any object as an s-expression (using `prin1').
3194 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3195 Use %% to put a single % into the output.
3197 The basic structure of a %-sequence is
3198 % <flags> <width> <precision> character
3199 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3201 usage: (format STRING &rest OBJECTS) */)
3204 register Lisp_Object
*args
;
3206 register int n
; /* The number of the next arg to substitute */
3207 register int total
; /* An estimate of the final length */
3209 register unsigned char *format
, *end
, *format_start
;
3211 /* Nonzero if the output should be a multibyte string,
3212 which is true if any of the inputs is one. */
3214 /* When we make a multibyte string, we must pay attention to the
3215 byte combining problem, i.e., a byte may be combined with a
3216 multibyte charcter of the previous string. This flag tells if we
3217 must consider such a situation or not. */
3218 int maybe_combine_byte
;
3219 unsigned char *this_format
;
3220 /* Precision for each spec, or -1, a flag value meaning no precision
3221 was given in that spec. Element 0, corresonding to the format
3222 string itself, will not be used. Element NARGS, corresponding to
3223 no argument, *will* be assigned to in the case that a `%' and `.'
3224 occur after the final format specifier. */
3225 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3228 int arg_intervals
= 0;
3231 /* discarded[I] is 1 if byte I of the format
3232 string was not copied into the output.
3233 It is 2 if byte I was not the first byte of its character. */
3236 /* Each element records, for one argument,
3237 the start and end bytepos in the output string,
3238 and whether the argument is a string with intervals.
3239 info[0] is unused. Unused elements have -1 for start. */
3242 int start
, end
, intervals
;
3245 /* It should not be necessary to GCPRO ARGS, because
3246 the caller in the interpreter should take care of that. */
3248 /* Try to determine whether the result should be multibyte.
3249 This is not always right; sometimes the result needs to be multibyte
3250 because of an object that we will pass through prin1,
3251 and in that case, we won't know it here. */
3252 for (n
= 0; n
< nargs
; n
++)
3254 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3256 /* Piggyback on this loop to initialize precision[N]. */
3259 precision
[nargs
] = -1;
3261 CHECK_STRING (args
[0]);
3262 /* We may have to change "%S" to "%s". */
3263 args
[0] = Fcopy_sequence (args
[0]);
3265 /* GC should never happen here, so abort if it does. */
3268 /* If we start out planning a unibyte result,
3269 then discover it has to be multibyte, we jump back to retry.
3270 That can only happen from the first large while loop below. */
3273 format
= SDATA (args
[0]);
3274 format_start
= format
;
3275 end
= format
+ SBYTES (args
[0]);
3278 /* Make room in result for all the non-%-codes in the control string. */
3279 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3281 /* Allocate the info and discarded tables. */
3283 int nbytes
= (nargs
+1) * sizeof *info
;
3285 info
= (struct info
*) alloca (nbytes
);
3286 bzero (info
, nbytes
);
3287 for (i
= 0; i
<= nargs
; i
++)
3289 discarded
= (char *) alloca (SBYTES (args
[0]));
3290 bzero (discarded
, SBYTES (args
[0]));
3293 /* Add to TOTAL enough space to hold the converted arguments. */
3296 while (format
!= end
)
3297 if (*format
++ == '%')
3300 int actual_width
= 0;
3301 unsigned char *this_format_start
= format
- 1;
3302 int field_width
= 0;
3304 /* General format specifications look like
3306 '%' [flags] [field-width] [precision] format
3311 field-width ::= [0-9]+
3312 precision ::= '.' [0-9]*
3314 If a field-width is specified, it specifies to which width
3315 the output should be padded with blanks, iff the output
3316 string is shorter than field-width.
3318 If precision is specified, it specifies the number of
3319 digits to print after the '.' for floats, or the max.
3320 number of chars to print from a string. */
3322 while (index ("-0# ", *format
))
3325 if (*format
>= '0' && *format
<= '9')
3327 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3328 field_width
= 10 * field_width
+ *format
- '0';
3331 /* N is not incremented for another few lines below, so refer to
3332 element N+1 (which might be precision[NARGS]). */
3336 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3337 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3340 if (format
- this_format_start
+ 1 > longest_format
)
3341 longest_format
= format
- this_format_start
+ 1;
3344 error ("Format string ends in middle of format specifier");
3347 else if (++n
>= nargs
)
3348 error ("Not enough arguments for format string");
3349 else if (*format
== 'S')
3351 /* For `S', prin1 the argument and then treat like a string. */
3352 register Lisp_Object tem
;
3353 tem
= Fprin1_to_string (args
[n
], Qnil
);
3354 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3360 /* If we restart the loop, we should not come here again
3361 because args[n] is now a string and calling
3362 Fprin1_to_string on it produces superflous double
3363 quotes. So, change "%S" to "%s" now. */
3367 else if (SYMBOLP (args
[n
]))
3369 args
[n
] = SYMBOL_NAME (args
[n
]);
3370 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3377 else if (STRINGP (args
[n
]))
3380 if (*format
!= 's' && *format
!= 'S')
3381 error ("Format specifier doesn't match argument type");
3382 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3383 to be as large as is calculated here. Easy check for
3384 the case PRECISION = 0. */
3385 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3386 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3388 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3389 else if (INTEGERP (args
[n
]) && *format
!= 's')
3391 /* The following loop assumes the Lisp type indicates
3392 the proper way to pass the argument.
3393 So make sure we have a flonum if the argument should
3395 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3396 args
[n
] = Ffloat (args
[n
]);
3398 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3399 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3400 error ("Invalid format operation %%%c", *format
);
3405 if (! SINGLE_BYTE_CHAR_P (XINT (args
[n
]))
3406 /* Note: No one can remember why we have to treat
3407 the character 0 as a multibyte character here.
3408 But, until it causes a real problem, let's
3410 || XINT (args
[n
]) == 0)
3417 args
[n
] = Fchar_to_string (args
[n
]);
3418 thissize
= SBYTES (args
[n
]);
3420 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3423 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3424 thissize
= SBYTES (args
[n
]);
3428 else if (FLOATP (args
[n
]) && *format
!= 's')
3430 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3432 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3433 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3434 error ("Invalid format operation %%%c", *format
);
3435 args
[n
] = Ftruncate (args
[n
], Qnil
);
3438 /* Note that we're using sprintf to print floats,
3439 so we have to take into account what that function
3441 /* Filter out flag value of -1. */
3442 thissize
= (MAX_10_EXP
+ 100
3443 + (precision
[n
] > 0 ? precision
[n
] : 0));
3447 /* Anything but a string, convert to a string using princ. */
3448 register Lisp_Object tem
;
3449 tem
= Fprin1_to_string (args
[n
], Qt
);
3450 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3459 thissize
+= max (0, field_width
- actual_width
);
3460 total
+= thissize
+ 4;
3465 /* Now we can no longer jump to retry.
3466 TOTAL and LONGEST_FORMAT are known for certain. */
3468 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3470 /* Allocate the space for the result.
3471 Note that TOTAL is an overestimate. */
3472 SAFE_ALLOCA (buf
, char *, total
);
3478 /* Scan the format and store result in BUF. */
3479 format
= SDATA (args
[0]);
3480 format_start
= format
;
3481 end
= format
+ SBYTES (args
[0]);
3482 maybe_combine_byte
= 0;
3483 while (format
!= end
)
3489 unsigned char *this_format_start
= format
;
3491 discarded
[format
- format_start
] = 1;
3494 while (index("-0# ", *format
))
3500 discarded
[format
- format_start
] = 1;
3504 minlen
= atoi (format
);
3506 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3508 discarded
[format
- format_start
] = 1;
3512 if (*format
++ == '%')
3521 discarded
[format
- format_start
- 1] = 1;
3522 info
[n
].start
= nchars
;
3524 if (STRINGP (args
[n
]))
3526 /* handle case (precision[n] >= 0) */
3529 int nbytes
, start
, end
;
3532 /* lisp_string_width ignores a precision of 0, but GNU
3533 libc functions print 0 characters when the precision
3534 is 0. Imitate libc behavior here. Changing
3535 lisp_string_width is the right thing, and will be
3536 done, but meanwhile we work with it. */
3538 if (precision
[n
] == 0)
3539 width
= nchars_string
= nbytes
= 0;
3540 else if (precision
[n
] > 0)
3541 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3543 { /* no precision spec given for this argument */
3544 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3545 nbytes
= SBYTES (args
[n
]);
3546 nchars_string
= SCHARS (args
[n
]);
3549 /* If spec requires it, pad on right with spaces. */
3550 padding
= minlen
- width
;
3552 while (padding
-- > 0)
3559 nchars
+= nchars_string
;
3564 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3565 && STRING_MULTIBYTE (args
[n
])
3566 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3567 maybe_combine_byte
= 1;
3569 p
+= copy_text (SDATA (args
[n
]), p
,
3571 STRING_MULTIBYTE (args
[n
]), multibyte
);
3574 while (padding
-- > 0)
3580 /* If this argument has text properties, record where
3581 in the result string it appears. */
3582 if (STRING_INTERVALS (args
[n
]))
3583 info
[n
].intervals
= arg_intervals
= 1;
3585 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3589 bcopy (this_format_start
, this_format
,
3590 format
- this_format_start
);
3591 this_format
[format
- this_format_start
] = 0;
3593 if (INTEGERP (args
[n
]))
3594 sprintf (p
, this_format
, XINT (args
[n
]));
3596 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3600 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3601 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3602 maybe_combine_byte
= 1;
3603 this_nchars
= strlen (p
);
3605 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3608 nchars
+= this_nchars
;
3611 info
[n
].end
= nchars
;
3613 else if (STRING_MULTIBYTE (args
[0]))
3615 /* Copy a whole multibyte character. */
3618 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3619 && !CHAR_HEAD_P (*format
))
3620 maybe_combine_byte
= 1;
3622 while (! CHAR_HEAD_P (*format
))
3624 discarded
[format
- format_start
] = 2;
3631 /* Convert a single-byte character to multibyte. */
3632 int len
= copy_text (format
, p
, 1, 0, 1);
3639 *p
++ = *format
++, nchars
++;
3642 if (p
> buf
+ total
)
3645 if (maybe_combine_byte
)
3646 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3647 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3649 /* If we allocated BUF with malloc, free it too. */
3652 /* If the format string has text properties, or any of the string
3653 arguments has text properties, set up text properties of the
3656 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3658 Lisp_Object len
, new_len
, props
;
3659 struct gcpro gcpro1
;
3661 /* Add text properties from the format string. */
3662 len
= make_number (SCHARS (args
[0]));
3663 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3668 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3671 /* Adjust the bounds of each text property
3672 to the proper start and end in the output string. */
3674 /* Put the positions in PROPS in increasing order, so that
3675 we can do (effectively) one scan through the position
3676 space of the format string. */
3677 props
= Fnreverse (props
);
3679 /* BYTEPOS is the byte position in the format string,
3680 POSITION is the untranslated char position in it,
3681 TRANSLATED is the translated char position in BUF,
3682 and ARGN is the number of the next arg we will come to. */
3683 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3690 /* First adjust the property start position. */
3691 pos
= XINT (XCAR (item
));
3693 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3694 up to this position. */
3695 for (; position
< pos
; bytepos
++)
3697 if (! discarded
[bytepos
])
3698 position
++, translated
++;
3699 else if (discarded
[bytepos
] == 1)
3702 if (translated
== info
[argn
].start
)
3704 translated
+= info
[argn
].end
- info
[argn
].start
;
3710 XSETCAR (item
, make_number (translated
));
3712 /* Likewise adjust the property end position. */
3713 pos
= XINT (XCAR (XCDR (item
)));
3715 for (; bytepos
< pos
; bytepos
++)
3717 if (! discarded
[bytepos
])
3718 position
++, translated
++;
3719 else if (discarded
[bytepos
] == 1)
3722 if (translated
== info
[argn
].start
)
3724 translated
+= info
[argn
].end
- info
[argn
].start
;
3730 XSETCAR (XCDR (item
), make_number (translated
));
3733 add_text_properties_from_list (val
, props
, make_number (0));
3736 /* Add text properties from arguments. */
3738 for (n
= 1; n
< nargs
; ++n
)
3739 if (info
[n
].intervals
)
3741 len
= make_number (SCHARS (args
[n
]));
3742 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3743 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3744 extend_property_ranges (props
, len
, new_len
);
3745 /* If successive arguments have properites, be sure that
3746 the value of `composition' property be the copy. */
3747 if (n
> 1 && info
[n
- 1].end
)
3748 make_composition_value_copy (props
);
3749 add_text_properties_from_list (val
, props
,
3750 make_number (info
[n
].start
));
3760 format2 (string1
, arg0
, arg1
)
3762 Lisp_Object arg0
, arg1
;
3764 Lisp_Object args
[3];
3765 args
[0] = build_string (string1
);
3768 return Fformat (3, args
);
3771 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
3772 doc
: /* Return t if two characters match, optionally ignoring case.
3773 Both arguments must be characters (i.e. integers).
3774 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
3776 register Lisp_Object c1
, c2
;
3782 if (XINT (c1
) == XINT (c2
))
3784 if (NILP (current_buffer
->case_fold_search
))
3787 /* Do these in separate statements,
3788 then compare the variables.
3789 because of the way DOWNCASE uses temp variables. */
3790 i1
= DOWNCASE (XFASTINT (c1
));
3791 i2
= DOWNCASE (XFASTINT (c2
));
3792 return (i1
== i2
? Qt
: Qnil
);
3795 /* Transpose the markers in two regions of the current buffer, and
3796 adjust the ones between them if necessary (i.e.: if the regions
3799 START1, END1 are the character positions of the first region.
3800 START1_BYTE, END1_BYTE are the byte positions.
3801 START2, END2 are the character positions of the second region.
3802 START2_BYTE, END2_BYTE are the byte positions.
3804 Traverses the entire marker list of the buffer to do so, adding an
3805 appropriate amount to some, subtracting from some, and leaving the
3806 rest untouched. Most of this is copied from adjust_markers in insdel.c.
3808 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
3811 transpose_markers (start1
, end1
, start2
, end2
,
3812 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
3813 register int start1
, end1
, start2
, end2
;
3814 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
3816 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
3817 register struct Lisp_Marker
*marker
;
3819 /* Update point as if it were a marker. */
3823 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
3824 PT_BYTE
+ (end2_byte
- end1_byte
));
3825 else if (PT
< start2
)
3826 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
3827 (PT_BYTE
+ (end2_byte
- start2_byte
)
3828 - (end1_byte
- start1_byte
)));
3830 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
3831 PT_BYTE
- (start2_byte
- start1_byte
));
3833 /* We used to adjust the endpoints here to account for the gap, but that
3834 isn't good enough. Even if we assume the caller has tried to move the
3835 gap out of our way, it might still be at start1 exactly, for example;
3836 and that places it `inside' the interval, for our purposes. The amount
3837 of adjustment is nontrivial if there's a `denormalized' marker whose
3838 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
3839 the dirty work to Fmarker_position, below. */
3841 /* The difference between the region's lengths */
3842 diff
= (end2
- start2
) - (end1
- start1
);
3843 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
3845 /* For shifting each marker in a region by the length of the other
3846 region plus the distance between the regions. */
3847 amt1
= (end2
- start2
) + (start2
- end1
);
3848 amt2
= (end1
- start1
) + (start2
- end1
);
3849 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
3850 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
3852 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
3854 mpos
= marker
->bytepos
;
3855 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
3857 if (mpos
< end1_byte
)
3859 else if (mpos
< start2_byte
)
3863 marker
->bytepos
= mpos
;
3865 mpos
= marker
->charpos
;
3866 if (mpos
>= start1
&& mpos
< end2
)
3870 else if (mpos
< start2
)
3875 marker
->charpos
= mpos
;
3879 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
3880 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
3881 The regions may not be overlapping, because the size of the buffer is
3882 never changed in a transposition.
3884 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
3885 any markers that happen to be located in the regions.
3887 Transposing beyond buffer boundaries is an error. */)
3888 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
3889 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
3891 register int start1
, end1
, start2
, end2
;
3892 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
3893 int gap
, len1
, len_mid
, len2
;
3894 unsigned char *start1_addr
, *start2_addr
, *temp
;
3896 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
3897 cur_intv
= BUF_INTERVALS (current_buffer
);
3899 validate_region (&startr1
, &endr1
);
3900 validate_region (&startr2
, &endr2
);
3902 start1
= XFASTINT (startr1
);
3903 end1
= XFASTINT (endr1
);
3904 start2
= XFASTINT (startr2
);
3905 end2
= XFASTINT (endr2
);
3908 /* Swap the regions if they're reversed. */
3911 register int glumph
= start1
;
3919 len1
= end1
- start1
;
3920 len2
= end2
- start2
;
3923 error ("Transposed regions overlap");
3924 else if (start1
== end1
|| start2
== end2
)
3925 error ("Transposed region has length 0");
3927 /* The possibilities are:
3928 1. Adjacent (contiguous) regions, or separate but equal regions
3929 (no, really equal, in this case!), or
3930 2. Separate regions of unequal size.
3932 The worst case is usually No. 2. It means that (aside from
3933 potential need for getting the gap out of the way), there also
3934 needs to be a shifting of the text between the two regions. So
3935 if they are spread far apart, we are that much slower... sigh. */
3937 /* It must be pointed out that the really studly thing to do would
3938 be not to move the gap at all, but to leave it in place and work
3939 around it if necessary. This would be extremely efficient,
3940 especially considering that people are likely to do
3941 transpositions near where they are working interactively, which
3942 is exactly where the gap would be found. However, such code
3943 would be much harder to write and to read. So, if you are
3944 reading this comment and are feeling squirrely, by all means have
3945 a go! I just didn't feel like doing it, so I will simply move
3946 the gap the minimum distance to get it out of the way, and then
3947 deal with an unbroken array. */
3949 /* Make sure the gap won't interfere, by moving it out of the text
3950 we will operate on. */
3951 if (start1
< gap
&& gap
< end2
)
3953 if (gap
- start1
< end2
- gap
)
3959 start1_byte
= CHAR_TO_BYTE (start1
);
3960 start2_byte
= CHAR_TO_BYTE (start2
);
3961 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
3962 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
3964 #ifdef BYTE_COMBINING_DEBUG
3967 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
3968 len2_byte
, start1
, start1_byte
)
3969 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
3970 len1_byte
, end2
, start2_byte
+ len2_byte
)
3971 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
3972 len1_byte
, end2
, start2_byte
+ len2_byte
))
3977 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
3978 len2_byte
, start1
, start1_byte
)
3979 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
3980 len1_byte
, start2
, start2_byte
)
3981 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
3982 len2_byte
, end1
, start1_byte
+ len1_byte
)
3983 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
3984 len1_byte
, end2
, start2_byte
+ len2_byte
))
3989 /* Hmmm... how about checking to see if the gap is large
3990 enough to use as the temporary storage? That would avoid an
3991 allocation... interesting. Later, don't fool with it now. */
3993 /* Working without memmove, for portability (sigh), so must be
3994 careful of overlapping subsections of the array... */
3996 if (end1
== start2
) /* adjacent regions */
3998 modify_region (current_buffer
, start1
, end2
);
3999 record_change (start1
, len1
+ len2
);
4001 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4002 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4003 Fset_text_properties (make_number (start1
), make_number (end2
),
4006 /* First region smaller than second. */
4007 if (len1_byte
< len2_byte
)
4011 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4013 /* Don't precompute these addresses. We have to compute them
4014 at the last minute, because the relocating allocator might
4015 have moved the buffer around during the xmalloc. */
4016 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4017 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4019 bcopy (start2_addr
, temp
, len2_byte
);
4020 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4021 bcopy (temp
, start1_addr
, len2_byte
);
4022 SAFE_FREE (len2_byte
);
4025 /* First region not smaller than second. */
4029 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4030 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4031 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4032 bcopy (start1_addr
, temp
, len1_byte
);
4033 bcopy (start2_addr
, start1_addr
, len2_byte
);
4034 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4035 SAFE_FREE (len1_byte
);
4037 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4038 len1
, current_buffer
, 0);
4039 graft_intervals_into_buffer (tmp_interval2
, start1
,
4040 len2
, current_buffer
, 0);
4041 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4042 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4044 /* Non-adjacent regions, because end1 != start2, bleagh... */
4047 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4049 if (len1_byte
== len2_byte
)
4050 /* Regions are same size, though, how nice. */
4054 modify_region (current_buffer
, start1
, end1
);
4055 modify_region (current_buffer
, start2
, end2
);
4056 record_change (start1
, len1
);
4057 record_change (start2
, len2
);
4058 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4059 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4060 Fset_text_properties (make_number (start1
), make_number (end1
),
4062 Fset_text_properties (make_number (start2
), make_number (end2
),
4065 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4066 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4067 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4068 bcopy (start1_addr
, temp
, len1_byte
);
4069 bcopy (start2_addr
, start1_addr
, len2_byte
);
4070 bcopy (temp
, start2_addr
, len1_byte
);
4071 SAFE_FREE (len1_byte
);
4073 graft_intervals_into_buffer (tmp_interval1
, start2
,
4074 len1
, current_buffer
, 0);
4075 graft_intervals_into_buffer (tmp_interval2
, start1
,
4076 len2
, current_buffer
, 0);
4079 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4080 /* Non-adjacent & unequal size, area between must also be shifted. */
4084 modify_region (current_buffer
, start1
, end2
);
4085 record_change (start1
, (end2
- start1
));
4086 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4087 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4088 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4089 Fset_text_properties (make_number (start1
), make_number (end2
),
4092 /* holds region 2 */
4093 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4094 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4095 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4096 bcopy (start2_addr
, temp
, len2_byte
);
4097 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4098 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4099 bcopy (temp
, start1_addr
, len2_byte
);
4100 SAFE_FREE (len2_byte
);
4102 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4103 len1
, current_buffer
, 0);
4104 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4105 len_mid
, current_buffer
, 0);
4106 graft_intervals_into_buffer (tmp_interval2
, start1
,
4107 len2
, current_buffer
, 0);
4110 /* Second region smaller than first. */
4114 record_change (start1
, (end2
- start1
));
4115 modify_region (current_buffer
, start1
, end2
);
4117 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4118 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4119 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4120 Fset_text_properties (make_number (start1
), make_number (end2
),
4123 /* holds region 1 */
4124 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4125 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4126 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4127 bcopy (start1_addr
, temp
, len1_byte
);
4128 bcopy (start2_addr
, start1_addr
, len2_byte
);
4129 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4130 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4131 SAFE_FREE (len1_byte
);
4133 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4134 len1
, current_buffer
, 0);
4135 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4136 len_mid
, current_buffer
, 0);
4137 graft_intervals_into_buffer (tmp_interval2
, start1
,
4138 len2
, current_buffer
, 0);
4141 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4142 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4145 /* When doing multiple transpositions, it might be nice
4146 to optimize this. Perhaps the markers in any one buffer
4147 should be organized in some sorted data tree. */
4148 if (NILP (leave_markers
))
4150 transpose_markers (start1
, end1
, start2
, end2
,
4151 start1_byte
, start1_byte
+ len1_byte
,
4152 start2_byte
, start2_byte
+ len2_byte
);
4153 fix_start_end_in_overlays (start1
, end2
);
4165 Qbuffer_access_fontify_functions
4166 = intern ("buffer-access-fontify-functions");
4167 staticpro (&Qbuffer_access_fontify_functions
);
4169 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4170 doc
: /* Non-nil means text motion commands don't notice fields. */);
4171 Vinhibit_field_text_motion
= Qnil
;
4173 DEFVAR_LISP ("buffer-access-fontify-functions",
4174 &Vbuffer_access_fontify_functions
,
4175 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4176 Each function is called with two arguments which specify the range
4177 of the buffer being accessed. */);
4178 Vbuffer_access_fontify_functions
= Qnil
;
4182 extern Lisp_Object Vprin1_to_string_buffer
;
4183 obuf
= Fcurrent_buffer ();
4184 /* Do this here, because init_buffer_once is too early--it won't work. */
4185 Fset_buffer (Vprin1_to_string_buffer
);
4186 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4187 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4192 DEFVAR_LISP ("buffer-access-fontified-property",
4193 &Vbuffer_access_fontified_property
,
4194 doc
: /* Property which (if non-nil) indicates text has been fontified.
4195 `buffer-substring' need not call the `buffer-access-fontify-functions'
4196 functions if all the text being accessed has this property. */);
4197 Vbuffer_access_fontified_property
= Qnil
;
4199 DEFVAR_LISP ("system-name", &Vsystem_name
,
4200 doc
: /* The name of the machine Emacs is running on. */);
4202 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4203 doc
: /* The full name of the user logged in. */);
4205 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4206 doc
: /* The user's name, taken from environment variables if possible. */);
4208 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4209 doc
: /* The user's name, based upon the real uid only. */);
4211 defsubr (&Spropertize
);
4212 defsubr (&Schar_equal
);
4213 defsubr (&Sgoto_char
);
4214 defsubr (&Sstring_to_char
);
4215 defsubr (&Schar_to_string
);
4216 defsubr (&Sbuffer_substring
);
4217 defsubr (&Sbuffer_substring_no_properties
);
4218 defsubr (&Sbuffer_string
);
4220 defsubr (&Spoint_marker
);
4221 defsubr (&Smark_marker
);
4223 defsubr (&Sregion_beginning
);
4224 defsubr (&Sregion_end
);
4226 staticpro (&Qfield
);
4227 Qfield
= intern ("field");
4228 staticpro (&Qboundary
);
4229 Qboundary
= intern ("boundary");
4230 defsubr (&Sfield_beginning
);
4231 defsubr (&Sfield_end
);
4232 defsubr (&Sfield_string
);
4233 defsubr (&Sfield_string_no_properties
);
4234 defsubr (&Sdelete_field
);
4235 defsubr (&Sconstrain_to_field
);
4237 defsubr (&Sline_beginning_position
);
4238 defsubr (&Sline_end_position
);
4240 /* defsubr (&Smark); */
4241 /* defsubr (&Sset_mark); */
4242 defsubr (&Ssave_excursion
);
4243 defsubr (&Ssave_current_buffer
);
4245 defsubr (&Sbufsize
);
4246 defsubr (&Spoint_max
);
4247 defsubr (&Spoint_min
);
4248 defsubr (&Spoint_min_marker
);
4249 defsubr (&Spoint_max_marker
);
4250 defsubr (&Sgap_position
);
4251 defsubr (&Sgap_size
);
4252 defsubr (&Sposition_bytes
);
4253 defsubr (&Sbyte_to_position
);
4259 defsubr (&Sfollowing_char
);
4260 defsubr (&Sprevious_char
);
4261 defsubr (&Schar_after
);
4262 defsubr (&Schar_before
);
4264 defsubr (&Sinsert_before_markers
);
4265 defsubr (&Sinsert_and_inherit
);
4266 defsubr (&Sinsert_and_inherit_before_markers
);
4267 defsubr (&Sinsert_char
);
4269 defsubr (&Suser_login_name
);
4270 defsubr (&Suser_real_login_name
);
4271 defsubr (&Suser_uid
);
4272 defsubr (&Suser_real_uid
);
4273 defsubr (&Suser_full_name
);
4274 defsubr (&Semacs_pid
);
4275 defsubr (&Scurrent_time
);
4276 defsubr (&Sformat_time_string
);
4277 defsubr (&Sfloat_time
);
4278 defsubr (&Sdecode_time
);
4279 defsubr (&Sencode_time
);
4280 defsubr (&Scurrent_time_string
);
4281 defsubr (&Scurrent_time_zone
);
4282 defsubr (&Sset_time_zone_rule
);
4283 defsubr (&Ssystem_name
);
4284 defsubr (&Smessage
);
4285 defsubr (&Smessage_box
);
4286 defsubr (&Smessage_or_box
);
4287 defsubr (&Scurrent_message
);
4290 defsubr (&Sinsert_buffer_substring
);
4291 defsubr (&Scompare_buffer_substrings
);
4292 defsubr (&Ssubst_char_in_region
);
4293 defsubr (&Stranslate_region
);
4294 defsubr (&Sdelete_region
);
4295 defsubr (&Sdelete_and_extract_region
);
4297 defsubr (&Snarrow_to_region
);
4298 defsubr (&Ssave_restriction
);
4299 defsubr (&Stranspose_regions
);
4302 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4303 (do not change this comment) */