1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993, 1994, 1995, 1996,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005, 2006 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
25 #include <sys/types.h>
36 #ifdef HAVE_SYS_UTSNAME_H
37 #include <sys/utsname.h>
42 /* systime.h includes <sys/time.h> which, on some systems, is required
43 for <sys/resource.h>; thus systime.h must be included before
47 #if defined HAVE_SYS_RESOURCE_H
48 #include <sys/resource.h>
53 #include "intervals.h"
55 #include "character.h"
62 #define MAX_10_EXP DBL_MAX_10_EXP
64 #define MAX_10_EXP 310
72 extern char **environ
;
75 extern size_t emacs_strftimeu
P_ ((char *, size_t, const char *,
76 const struct tm
*, int));
77 static int tm_diff
P_ ((struct tm
*, struct tm
*));
78 static void find_field
P_ ((Lisp_Object
, Lisp_Object
, Lisp_Object
, int *, Lisp_Object
, int *));
79 static void update_buffer_properties
P_ ((int, int));
80 static Lisp_Object region_limit
P_ ((int));
81 int lisp_time_argument
P_ ((Lisp_Object
, time_t *, int *));
82 static size_t emacs_memftimeu
P_ ((char *, size_t, const char *,
83 size_t, const struct tm
*, int));
84 static void general_insert_function
P_ ((void (*) (const unsigned char *, int),
85 void (*) (Lisp_Object
, int, int, int,
87 int, int, Lisp_Object
*));
88 static Lisp_Object subst_char_in_region_unwind
P_ ((Lisp_Object
));
89 static Lisp_Object subst_char_in_region_unwind_1
P_ ((Lisp_Object
));
90 static void transpose_markers
P_ ((int, int, int, int, int, int, int, int));
93 extern char *index
P_ ((const char *, int));
96 Lisp_Object Vbuffer_access_fontify_functions
;
97 Lisp_Object Qbuffer_access_fontify_functions
;
98 Lisp_Object Vbuffer_access_fontified_property
;
100 Lisp_Object Fuser_full_name
P_ ((Lisp_Object
));
102 /* Non-nil means don't stop at field boundary in text motion commands. */
104 Lisp_Object Vinhibit_field_text_motion
;
106 /* Some static data, and a function to initialize it for each run */
108 Lisp_Object Vsystem_name
;
109 Lisp_Object Vuser_real_login_name
; /* login name of current user ID */
110 Lisp_Object Vuser_full_name
; /* full name of current user */
111 Lisp_Object Vuser_login_name
; /* user name from LOGNAME or USER */
112 Lisp_Object Voperating_system_release
; /* Operating System Release */
114 /* Symbol for the text property used to mark fields. */
118 /* A special value for Qfield properties. */
120 Lisp_Object Qboundary
;
127 register unsigned char *p
;
128 struct passwd
*pw
; /* password entry for the current user */
131 /* Set up system_name even when dumping. */
135 /* Don't bother with this on initial start when just dumping out */
138 #endif /* not CANNOT_DUMP */
140 pw
= (struct passwd
*) getpwuid (getuid ());
142 /* We let the real user name default to "root" because that's quite
143 accurate on MSDOG and because it lets Emacs find the init file.
144 (The DVX libraries override the Djgpp libraries here.) */
145 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "root");
147 Vuser_real_login_name
= build_string (pw
? pw
->pw_name
: "unknown");
150 /* Get the effective user name, by consulting environment variables,
151 or the effective uid if those are unset. */
152 user_name
= (char *) getenv ("LOGNAME");
155 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
156 #else /* WINDOWSNT */
157 user_name
= (char *) getenv ("USER");
158 #endif /* WINDOWSNT */
161 pw
= (struct passwd
*) getpwuid (geteuid ());
162 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
164 Vuser_login_name
= build_string (user_name
);
166 /* If the user name claimed in the environment vars differs from
167 the real uid, use the claimed name to find the full name. */
168 tem
= Fstring_equal (Vuser_login_name
, Vuser_real_login_name
);
169 Vuser_full_name
= Fuser_full_name (NILP (tem
)? make_number (geteuid())
172 p
= (unsigned char *) getenv ("NAME");
174 Vuser_full_name
= build_string (p
);
175 else if (NILP (Vuser_full_name
))
176 Vuser_full_name
= build_string ("unknown");
178 #ifdef HAVE_SYS_UTSNAME_H
182 Voperating_system_release
= build_string (uts
.release
);
185 Voperating_system_release
= Qnil
;
189 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
190 doc
: /* Convert arg CHAR to a string containing that character.
191 usage: (char-to-string CHAR) */)
193 Lisp_Object character
;
196 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
198 CHECK_NUMBER (character
);
200 len
= CHAR_STRING (XFASTINT (character
), str
);
201 return make_string_from_bytes (str
, 1, len
);
204 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
205 doc
: /* Convert arg STRING to a character, the first character of that string.
206 A multibyte character is handled correctly. */)
208 register Lisp_Object string
;
210 register Lisp_Object val
;
211 CHECK_STRING (string
);
214 if (STRING_MULTIBYTE (string
))
215 XSETFASTINT (val
, STRING_CHAR (SDATA (string
), SBYTES (string
)));
217 XSETFASTINT (val
, SREF (string
, 0));
220 XSETFASTINT (val
, 0);
225 buildmark (charpos
, bytepos
)
226 int charpos
, bytepos
;
228 register Lisp_Object mark
;
229 mark
= Fmake_marker ();
230 set_marker_both (mark
, Qnil
, charpos
, bytepos
);
234 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
235 doc
: /* Return value of point, as an integer.
236 Beginning of buffer is position (point-min). */)
240 XSETFASTINT (temp
, PT
);
244 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
245 doc
: /* Return value of point, as a marker object. */)
248 return buildmark (PT
, PT_BYTE
);
252 clip_to_bounds (lower
, num
, upper
)
253 int lower
, num
, upper
;
257 else if (num
> upper
)
263 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
264 doc
: /* Set point to POSITION, a number or marker.
265 Beginning of buffer is position (point-min), end is (point-max). */)
267 register Lisp_Object position
;
271 if (MARKERP (position
)
272 && current_buffer
== XMARKER (position
)->buffer
)
274 pos
= marker_position (position
);
276 SET_PT_BOTH (BEGV
, BEGV_BYTE
);
278 SET_PT_BOTH (ZV
, ZV_BYTE
);
280 SET_PT_BOTH (pos
, marker_byte_position (position
));
285 CHECK_NUMBER_COERCE_MARKER (position
);
287 pos
= clip_to_bounds (BEGV
, XINT (position
), ZV
);
293 /* Return the start or end position of the region.
294 BEGINNINGP non-zero means return the start.
295 If there is no region active, signal an error. */
298 region_limit (beginningp
)
301 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
304 if (!NILP (Vtransient_mark_mode
)
305 && NILP (Vmark_even_if_inactive
)
306 && NILP (current_buffer
->mark_active
))
307 Fsignal (Qmark_inactive
, Qnil
);
309 m
= Fmarker_position (current_buffer
->mark
);
311 error ("The mark is not set now, so there is no region");
313 if ((PT
< XFASTINT (m
)) == (beginningp
!= 0))
314 m
= make_number (PT
);
318 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
319 doc
: /* Return position of beginning of region, as an integer. */)
322 return region_limit (1);
325 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
326 doc
: /* Return position of end of region, as an integer. */)
329 return region_limit (0);
332 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
333 doc
: /* Return this buffer's mark, as a marker object.
334 Watch out! Moving this marker changes the mark position.
335 If you set the marker not to point anywhere, the buffer will have no mark. */)
338 return current_buffer
->mark
;
342 /* Find all the overlays in the current buffer that touch position POS.
343 Return the number found, and store them in a vector in VEC
347 overlays_around (pos
, vec
, len
)
352 Lisp_Object overlay
, start
, end
;
353 struct Lisp_Overlay
*tail
;
354 int startpos
, endpos
;
357 for (tail
= current_buffer
->overlays_before
; tail
; tail
= tail
->next
)
359 XSETMISC (overlay
, tail
);
361 end
= OVERLAY_END (overlay
);
362 endpos
= OVERLAY_POSITION (end
);
365 start
= OVERLAY_START (overlay
);
366 startpos
= OVERLAY_POSITION (start
);
371 /* Keep counting overlays even if we can't return them all. */
376 for (tail
= current_buffer
->overlays_after
; tail
; tail
= tail
->next
)
378 XSETMISC (overlay
, tail
);
380 start
= OVERLAY_START (overlay
);
381 startpos
= OVERLAY_POSITION (start
);
384 end
= OVERLAY_END (overlay
);
385 endpos
= OVERLAY_POSITION (end
);
397 /* Return the value of property PROP, in OBJECT at POSITION.
398 It's the value of PROP that a char inserted at POSITION would get.
399 OBJECT is optional and defaults to the current buffer.
400 If OBJECT is a buffer, then overlay properties are considered as well as
402 If OBJECT is a window, then that window's buffer is used, but
403 window-specific overlays are considered only if they are associated
406 get_pos_property (position
, prop
, object
)
407 Lisp_Object position
, object
;
408 register Lisp_Object prop
;
410 CHECK_NUMBER_COERCE_MARKER (position
);
413 XSETBUFFER (object
, current_buffer
);
414 else if (WINDOWP (object
))
415 object
= XWINDOW (object
)->buffer
;
417 if (!BUFFERP (object
))
418 /* pos-property only makes sense in buffers right now, since strings
419 have no overlays and no notion of insertion for which stickiness
421 return Fget_text_property (position
, prop
, object
);
424 int posn
= XINT (position
);
426 Lisp_Object
*overlay_vec
, tem
;
427 struct buffer
*obuf
= current_buffer
;
429 set_buffer_temp (XBUFFER (object
));
431 /* First try with room for 40 overlays. */
433 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
434 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
436 /* If there are more than 40,
437 make enough space for all, and try again. */
440 overlay_vec
= (Lisp_Object
*) alloca (noverlays
* sizeof (Lisp_Object
));
441 noverlays
= overlays_around (posn
, overlay_vec
, noverlays
);
443 noverlays
= sort_overlays (overlay_vec
, noverlays
, NULL
);
445 set_buffer_temp (obuf
);
447 /* Now check the overlays in order of decreasing priority. */
448 while (--noverlays
>= 0)
450 Lisp_Object ol
= overlay_vec
[noverlays
];
451 tem
= Foverlay_get (ol
, prop
);
454 /* Check the overlay is indeed active at point. */
455 Lisp_Object start
= OVERLAY_START (ol
), finish
= OVERLAY_END (ol
);
456 if ((OVERLAY_POSITION (start
) == posn
457 && XMARKER (start
)->insertion_type
== 1)
458 || (OVERLAY_POSITION (finish
) == posn
459 && XMARKER (finish
)->insertion_type
== 0))
460 ; /* The overlay will not cover a char inserted at point. */
468 { /* Now check the text-properties. */
469 int stickiness
= text_property_stickiness (prop
, position
, object
);
471 return Fget_text_property (position
, prop
, object
);
472 else if (stickiness
< 0
473 && XINT (position
) > BUF_BEGV (XBUFFER (object
)))
474 return Fget_text_property (make_number (XINT (position
) - 1),
482 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
483 the value of point is used instead. If BEG or END null,
484 means don't store the beginning or end of the field.
486 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
487 results; they do not effect boundary behavior.
489 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
490 position of a field, then the beginning of the previous field is
491 returned instead of the beginning of POS's field (since the end of a
492 field is actually also the beginning of the next input field, this
493 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
494 true case, if two fields are separated by a field with the special
495 value `boundary', and POS lies within it, then the two separated
496 fields are considered to be adjacent, and POS between them, when
497 finding the beginning and ending of the "merged" field.
499 Either BEG or END may be 0, in which case the corresponding value
503 find_field (pos
, merge_at_boundary
, beg_limit
, beg
, end_limit
, end
)
505 Lisp_Object merge_at_boundary
;
506 Lisp_Object beg_limit
, end_limit
;
509 /* Fields right before and after the point. */
510 Lisp_Object before_field
, after_field
;
511 /* 1 if POS counts as the start of a field. */
512 int at_field_start
= 0;
513 /* 1 if POS counts as the end of a field. */
514 int at_field_end
= 0;
517 XSETFASTINT (pos
, PT
);
519 CHECK_NUMBER_COERCE_MARKER (pos
);
522 = get_char_property_and_overlay (pos
, Qfield
, Qnil
, NULL
);
524 = (XFASTINT (pos
) > BEGV
525 ? get_char_property_and_overlay (make_number (XINT (pos
) - 1),
527 /* Using nil here would be a more obvious choice, but it would
528 fail when the buffer starts with a non-sticky field. */
531 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
532 and POS is at beginning of a field, which can also be interpreted
533 as the end of the previous field. Note that the case where if
534 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
535 more natural one; then we avoid treating the beginning of a field
537 if (NILP (merge_at_boundary
))
539 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
540 if (!EQ (field
, after_field
))
542 if (!EQ (field
, before_field
))
544 if (NILP (field
) && at_field_start
&& at_field_end
)
545 /* If an inserted char would have a nil field while the surrounding
546 text is non-nil, we're probably not looking at a
547 zero-length field, but instead at a non-nil field that's
548 not intended for editing (such as comint's prompts). */
549 at_field_end
= at_field_start
= 0;
552 /* Note about special `boundary' fields:
554 Consider the case where the point (`.') is between the fields `x' and `y':
558 In this situation, if merge_at_boundary is true, we consider the
559 `x' and `y' fields as forming one big merged field, and so the end
560 of the field is the end of `y'.
562 However, if `x' and `y' are separated by a special `boundary' field
563 (a field with a `field' char-property of 'boundary), then we ignore
564 this special field when merging adjacent fields. Here's the same
565 situation, but with a `boundary' field between the `x' and `y' fields:
569 Here, if point is at the end of `x', the beginning of `y', or
570 anywhere in-between (within the `boundary' field), we merge all
571 three fields and consider the beginning as being the beginning of
572 the `x' field, and the end as being the end of the `y' field. */
577 /* POS is at the edge of a field, and we should consider it as
578 the beginning of the following field. */
579 *beg
= XFASTINT (pos
);
581 /* Find the previous field boundary. */
584 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
585 /* Skip a `boundary' field. */
586 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
589 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
591 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
598 /* POS is at the edge of a field, and we should consider it as
599 the end of the previous field. */
600 *end
= XFASTINT (pos
);
602 /* Find the next field boundary. */
604 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
605 /* Skip a `boundary' field. */
606 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
609 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
611 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
617 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
618 doc
: /* Delete the field surrounding POS.
619 A field is a region of text with the same `field' property.
620 If POS is nil, the value of point is used for POS. */)
625 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
627 del_range (beg
, end
);
631 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
632 doc
: /* Return the contents of the field surrounding POS as a string.
633 A field is a region of text with the same `field' property.
634 If POS is nil, the value of point is used for POS. */)
639 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
640 return make_buffer_string (beg
, end
, 1);
643 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
644 doc
: /* Return the contents of the field around POS, without text-properties.
645 A field is a region of text with the same `field' property.
646 If POS is nil, the value of point is used for POS. */)
651 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
652 return make_buffer_string (beg
, end
, 0);
655 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
656 doc
: /* Return the beginning of the field surrounding POS.
657 A field is a region of text with the same `field' property.
658 If POS is nil, the value of point is used for POS.
659 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
660 field, then the beginning of the *previous* field is returned.
661 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
662 is before LIMIT, then LIMIT will be returned instead. */)
663 (pos
, escape_from_edge
, limit
)
664 Lisp_Object pos
, escape_from_edge
, limit
;
667 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
668 return make_number (beg
);
671 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
672 doc
: /* Return the end of the field surrounding POS.
673 A field is a region of text with the same `field' property.
674 If POS is nil, the value of point is used for POS.
675 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
676 then the end of the *following* field is returned.
677 If LIMIT is non-nil, it is a buffer position; if the end of the field
678 is after LIMIT, then LIMIT will be returned instead. */)
679 (pos
, escape_from_edge
, limit
)
680 Lisp_Object pos
, escape_from_edge
, limit
;
683 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
684 return make_number (end
);
687 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
688 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
690 A field is a region of text with the same `field' property.
691 If NEW-POS is nil, then the current point is used instead, and set to the
692 constrained position if that is different.
694 If OLD-POS is at the boundary of two fields, then the allowable
695 positions for NEW-POS depends on the value of the optional argument
696 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
697 constrained to the field that has the same `field' char-property
698 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
699 is non-nil, NEW-POS is constrained to the union of the two adjacent
700 fields. Additionally, if two fields are separated by another field with
701 the special value `boundary', then any point within this special field is
702 also considered to be `on the boundary'.
704 If the optional argument ONLY-IN-LINE is non-nil and constraining
705 NEW-POS would move it to a different line, NEW-POS is returned
706 unconstrained. This useful for commands that move by line, like
707 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
708 only in the case where they can still move to the right line.
710 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
711 a non-nil property of that name, then any field boundaries are ignored.
713 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
714 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
715 Lisp_Object new_pos
, old_pos
;
716 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
718 /* If non-zero, then the original point, before re-positioning. */
721 Lisp_Object prev_old
, prev_new
;
724 /* Use the current point, and afterwards, set it. */
727 XSETFASTINT (new_pos
, PT
);
730 CHECK_NUMBER_COERCE_MARKER (new_pos
);
731 CHECK_NUMBER_COERCE_MARKER (old_pos
);
733 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
735 prev_old
= make_number (XFASTINT (old_pos
) - 1);
736 prev_new
= make_number (XFASTINT (new_pos
) - 1);
738 if (NILP (Vinhibit_field_text_motion
)
739 && !EQ (new_pos
, old_pos
)
740 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
741 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
))
742 /* To recognize field boundaries, we must also look at the
743 previous positions; we could use `get_pos_property'
744 instead, but in itself that would fail inside non-sticky
745 fields (like comint prompts). */
746 || (XFASTINT (new_pos
) > BEGV
747 && !NILP (Fget_char_property (prev_new
, Qfield
, Qnil
)))
748 || (XFASTINT (old_pos
) > BEGV
749 && !NILP (Fget_char_property (prev_old
, Qfield
, Qnil
))))
750 && (NILP (inhibit_capture_property
)
751 /* Field boundaries are again a problem; but now we must
752 decide the case exactly, so we need to call
753 `get_pos_property' as well. */
754 || (NILP (get_pos_property (old_pos
, inhibit_capture_property
, Qnil
))
755 && (XFASTINT (old_pos
) <= BEGV
756 || NILP (Fget_char_property (old_pos
, inhibit_capture_property
, Qnil
))
757 || NILP (Fget_char_property (prev_old
, inhibit_capture_property
, Qnil
))))))
758 /* It is possible that NEW_POS is not within the same field as
759 OLD_POS; try to move NEW_POS so that it is. */
762 Lisp_Object field_bound
;
765 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
767 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
769 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
770 other side of NEW_POS, which would mean that NEW_POS is
771 already acceptable, and it's not necessary to constrain it
773 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
774 /* NEW_POS should be constrained, but only if either
775 ONLY_IN_LINE is nil (in which case any constraint is OK),
776 or NEW_POS and FIELD_BOUND are on the same line (in which
777 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
778 && (NILP (only_in_line
)
779 /* This is the ONLY_IN_LINE case, check that NEW_POS and
780 FIELD_BOUND are on the same line by seeing whether
781 there's an intervening newline or not. */
782 || (scan_buffer ('\n',
783 XFASTINT (new_pos
), XFASTINT (field_bound
),
784 fwd
? -1 : 1, &shortage
, 1),
786 /* Constrain NEW_POS to FIELD_BOUND. */
787 new_pos
= field_bound
;
789 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
790 /* The NEW_POS argument was originally nil, so automatically set PT. */
791 SET_PT (XFASTINT (new_pos
));
798 DEFUN ("line-beginning-position",
799 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
800 doc
: /* Return the character position of the first character on the current line.
801 With argument N not nil or 1, move forward N - 1 lines first.
802 If scan reaches end of buffer, return that position.
804 This function constrains the returned position to the current field
805 unless that would be on a different line than the original,
806 unconstrained result. If N is nil or 1, and a front-sticky field
807 starts at point, the scan stops as soon as it starts. To ignore field
808 boundaries bind `inhibit-field-text-motion' to t.
810 This function does not move point. */)
814 int orig
, orig_byte
, end
;
823 Fforward_line (make_number (XINT (n
) - 1));
826 SET_PT_BOTH (orig
, orig_byte
);
828 /* Return END constrained to the current input field. */
829 return Fconstrain_to_field (make_number (end
), make_number (orig
),
830 XINT (n
) != 1 ? Qt
: Qnil
,
834 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
835 doc
: /* Return the character position of the last character on the current line.
836 With argument N not nil or 1, move forward N - 1 lines first.
837 If scan reaches end of buffer, return that position.
839 This function constrains the returned position to the current field
840 unless that would be on a different line than the original,
841 unconstrained result. If N is nil or 1, and a rear-sticky field ends
842 at point, the scan stops as soon as it starts. To ignore field
843 boundaries bind `inhibit-field-text-motion' to t.
845 This function does not move point. */)
857 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
859 /* Return END_POS constrained to the current input field. */
860 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
866 save_excursion_save ()
868 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
871 return Fcons (Fpoint_marker (),
872 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
873 Fcons (visible
? Qt
: Qnil
,
874 Fcons (current_buffer
->mark_active
,
879 save_excursion_restore (info
)
882 Lisp_Object tem
, tem1
, omark
, nmark
;
883 struct gcpro gcpro1
, gcpro2
, gcpro3
;
886 tem
= Fmarker_buffer (XCAR (info
));
887 /* If buffer being returned to is now deleted, avoid error */
888 /* Otherwise could get error here while unwinding to top level
890 /* In that case, Fmarker_buffer returns nil now. */
894 omark
= nmark
= Qnil
;
895 GCPRO3 (info
, omark
, nmark
);
902 unchain_marker (XMARKER (tem
));
907 omark
= Fmarker_position (current_buffer
->mark
);
908 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
909 nmark
= Fmarker_position (tem
);
910 unchain_marker (XMARKER (tem
));
914 visible_p
= !NILP (XCAR (info
));
916 #if 0 /* We used to make the current buffer visible in the selected window
917 if that was true previously. That avoids some anomalies.
918 But it creates others, and it wasn't documented, and it is simpler
919 and cleaner never to alter the window/buffer connections. */
922 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
923 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
929 tem1
= current_buffer
->mark_active
;
930 current_buffer
->mark_active
= tem
;
932 if (!NILP (Vrun_hooks
))
934 /* If mark is active now, and either was not active
935 or was at a different place, run the activate hook. */
936 if (! NILP (current_buffer
->mark_active
))
938 if (! EQ (omark
, nmark
))
939 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
941 /* If mark has ceased to be active, run deactivate hook. */
942 else if (! NILP (tem1
))
943 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
946 /* If buffer was visible in a window, and a different window was
947 selected, and the old selected window is still showing this
948 buffer, restore point in that window. */
951 && !EQ (tem
, selected_window
)
952 && (tem1
= XWINDOW (tem
)->buffer
,
953 (/* Window is live... */
955 /* ...and it shows the current buffer. */
956 && XBUFFER (tem1
) == current_buffer
)))
957 Fset_window_point (tem
, make_number (PT
));
963 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
964 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
965 Executes BODY just like `progn'.
966 The values of point, mark and the current buffer are restored
967 even in case of abnormal exit (throw or error).
968 The state of activation of the mark is also restored.
970 This construct does not save `deactivate-mark', and therefore
971 functions that change the buffer will still cause deactivation
972 of the mark at the end of the command. To prevent that, bind
973 `deactivate-mark' with `let'.
975 usage: (save-excursion &rest BODY) */)
979 register Lisp_Object val
;
980 int count
= SPECPDL_INDEX ();
982 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
985 return unbind_to (count
, val
);
988 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
989 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
990 Executes BODY just like `progn'.
991 usage: (save-current-buffer &rest BODY) */)
996 int count
= SPECPDL_INDEX ();
998 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
1000 val
= Fprogn (args
);
1001 return unbind_to (count
, val
);
1004 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
1005 doc
: /* Return the number of characters in the current buffer.
1006 If BUFFER, return the number of characters in that buffer instead. */)
1011 return make_number (Z
- BEG
);
1014 CHECK_BUFFER (buffer
);
1015 return make_number (BUF_Z (XBUFFER (buffer
))
1016 - BUF_BEG (XBUFFER (buffer
)));
1020 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
1021 doc
: /* Return the minimum permissible value of point in the current buffer.
1022 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1026 XSETFASTINT (temp
, BEGV
);
1030 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1031 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1032 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1035 return buildmark (BEGV
, BEGV_BYTE
);
1038 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1039 doc
: /* Return the maximum permissible value of point in the current buffer.
1040 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1041 is in effect, in which case it is less. */)
1045 XSETFASTINT (temp
, ZV
);
1049 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1050 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1051 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1052 is in effect, in which case it is less. */)
1055 return buildmark (ZV
, ZV_BYTE
);
1058 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1059 doc
: /* Return the position of the gap, in the current buffer.
1060 See also `gap-size'. */)
1064 XSETFASTINT (temp
, GPT
);
1068 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1069 doc
: /* Return the size of the current buffer's gap.
1070 See also `gap-position'. */)
1074 XSETFASTINT (temp
, GAP_SIZE
);
1078 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1079 doc
: /* Return the byte position for character position POSITION.
1080 If POSITION is out of range, the value is nil. */)
1082 Lisp_Object position
;
1084 CHECK_NUMBER_COERCE_MARKER (position
);
1085 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1087 return make_number (CHAR_TO_BYTE (XINT (position
)));
1090 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1091 doc
: /* Return the character position for byte position BYTEPOS.
1092 If BYTEPOS is out of range, the value is nil. */)
1094 Lisp_Object bytepos
;
1096 CHECK_NUMBER (bytepos
);
1097 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1099 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1102 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1103 doc
: /* Return the character following point, as a number.
1104 At the end of the buffer or accessible region, return 0. */)
1109 XSETFASTINT (temp
, 0);
1111 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1115 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1116 doc
: /* Return the character preceding point, as a number.
1117 At the beginning of the buffer or accessible region, return 0. */)
1122 XSETFASTINT (temp
, 0);
1123 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1127 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1130 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1134 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1135 doc
: /* Return t if point is at the beginning of the buffer.
1136 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1144 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1145 doc
: /* Return t if point is at the end of the buffer.
1146 If the buffer is narrowed, this means the end of the narrowed part. */)
1154 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1155 doc
: /* Return t if point is at the beginning of a line. */)
1158 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1163 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1164 doc
: /* Return t if point is at the end of a line.
1165 `End of a line' includes point being at the end of the buffer. */)
1168 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1173 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1174 doc
: /* Return character in current buffer at position POS.
1175 POS is an integer or a marker and defaults to point.
1176 If POS is out of range, the value is nil. */)
1180 register int pos_byte
;
1185 XSETFASTINT (pos
, PT
);
1190 pos_byte
= marker_byte_position (pos
);
1191 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1196 CHECK_NUMBER_COERCE_MARKER (pos
);
1197 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1200 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1203 return make_number (FETCH_CHAR (pos_byte
));
1206 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1207 doc
: /* Return character in current buffer preceding position POS.
1208 POS is an integer or a marker and defaults to point.
1209 If POS is out of range, the value is nil. */)
1213 register Lisp_Object val
;
1214 register int pos_byte
;
1219 XSETFASTINT (pos
, PT
);
1224 pos_byte
= marker_byte_position (pos
);
1226 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1231 CHECK_NUMBER_COERCE_MARKER (pos
);
1233 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1236 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1239 if (!NILP (current_buffer
->enable_multibyte_characters
))
1242 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1247 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1252 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1253 doc
: /* Return the name under which the user logged in, as a string.
1254 This is based on the effective uid, not the real uid.
1255 Also, if the environment variables LOGNAME or USER are set,
1256 that determines the value of this function.
1258 If optional argument UID is an integer, return the login name of the user
1259 with that uid, or nil if there is no such user. */)
1265 /* Set up the user name info if we didn't do it before.
1266 (That can happen if Emacs is dumpable
1267 but you decide to run `temacs -l loadup' and not dump. */
1268 if (INTEGERP (Vuser_login_name
))
1272 return Vuser_login_name
;
1275 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1276 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1279 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1281 doc
: /* Return the name of the user's real uid, as a string.
1282 This ignores the environment variables LOGNAME and USER, so it differs from
1283 `user-login-name' when running under `su'. */)
1286 /* Set up the user name info if we didn't do it before.
1287 (That can happen if Emacs is dumpable
1288 but you decide to run `temacs -l loadup' and not dump. */
1289 if (INTEGERP (Vuser_login_name
))
1291 return Vuser_real_login_name
;
1294 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1295 doc
: /* Return the effective uid of Emacs.
1296 Value is an integer or float, depending on the value. */)
1299 return make_fixnum_or_float (geteuid ());
1302 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1303 doc
: /* Return the real uid of Emacs.
1304 Value is an integer or float, depending on the value. */)
1307 return make_fixnum_or_float (getuid ());
1310 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1311 doc
: /* Return the full name of the user logged in, as a string.
1312 If the full name corresponding to Emacs's userid is not known,
1315 If optional argument UID is an integer or float, return the full name
1316 of the user with that uid, or nil if there is no such user.
1317 If UID is a string, return the full name of the user with that login
1318 name, or nil if there is no such user. */)
1323 register unsigned char *p
, *q
;
1327 return Vuser_full_name
;
1328 else if (NUMBERP (uid
))
1329 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1330 else if (STRINGP (uid
))
1331 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1333 error ("Invalid UID specification");
1338 p
= (unsigned char *) USER_FULL_NAME
;
1339 /* Chop off everything after the first comma. */
1340 q
= (unsigned char *) index (p
, ',');
1341 full
= make_string (p
, q
? q
- p
: strlen (p
));
1343 #ifdef AMPERSAND_FULL_NAME
1345 q
= (unsigned char *) index (p
, '&');
1346 /* Substitute the login name for the &, upcasing the first character. */
1349 register unsigned char *r
;
1352 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1353 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1354 bcopy (p
, r
, q
- p
);
1356 strcat (r
, SDATA (login
));
1357 r
[q
- p
] = UPCASE (r
[q
- p
]);
1359 full
= build_string (r
);
1361 #endif /* AMPERSAND_FULL_NAME */
1366 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1367 doc
: /* Return the name of the machine you are running on, as a string. */)
1370 return Vsystem_name
;
1373 /* For the benefit of callers who don't want to include lisp.h */
1378 if (STRINGP (Vsystem_name
))
1379 return (char *) SDATA (Vsystem_name
);
1385 get_operating_system_release()
1387 if (STRINGP (Voperating_system_release
))
1388 return (char *) SDATA (Voperating_system_release
);
1393 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1394 doc
: /* Return the process ID of Emacs, as an integer. */)
1397 return make_number (getpid ());
1400 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1401 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1402 The time is returned as a list of three integers. The first has the
1403 most significant 16 bits of the seconds, while the second has the
1404 least significant 16 bits. The third integer gives the microsecond
1407 The microsecond count is zero on systems that do not provide
1408 resolution finer than a second. */)
1412 Lisp_Object result
[3];
1415 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1416 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1417 XSETINT (result
[2], EMACS_USECS (t
));
1419 return Flist (3, result
);
1422 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1424 doc
: /* Return the current run time used by Emacs.
1425 The time is returned as a list of three integers. The first has the
1426 most significant 16 bits of the seconds, while the second has the
1427 least significant 16 bits. The third integer gives the microsecond
1430 On systems that can't determine the run time, get-internal-run-time
1431 does the same thing as current-time. The microsecond count is zero on
1432 systems that do not provide resolution finer than a second. */)
1435 #ifdef HAVE_GETRUSAGE
1436 struct rusage usage
;
1437 Lisp_Object result
[3];
1440 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1441 /* This shouldn't happen. What action is appropriate? */
1442 Fsignal (Qerror
, Qnil
);
1444 /* Sum up user time and system time. */
1445 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1446 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1447 if (usecs
>= 1000000)
1453 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1454 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1455 XSETINT (result
[2], usecs
);
1457 return Flist (3, result
);
1459 return Fcurrent_time ();
1465 lisp_time_argument (specified_time
, result
, usec
)
1466 Lisp_Object specified_time
;
1470 if (NILP (specified_time
))
1477 *usec
= EMACS_USECS (t
);
1478 *result
= EMACS_SECS (t
);
1482 return time (result
) != -1;
1486 Lisp_Object high
, low
;
1487 high
= Fcar (specified_time
);
1488 CHECK_NUMBER (high
);
1489 low
= Fcdr (specified_time
);
1494 Lisp_Object usec_l
= Fcdr (low
);
1496 usec_l
= Fcar (usec_l
);
1501 CHECK_NUMBER (usec_l
);
1502 *usec
= XINT (usec_l
);
1510 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1511 return *result
>> 16 == XINT (high
);
1515 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1516 doc
: /* Return the current time, as a float number of seconds since the epoch.
1517 If SPECIFIED-TIME is given, it is the time to convert to float
1518 instead of the current time. The argument should have the form
1519 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1520 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1521 have the form (HIGH . LOW), but this is considered obsolete.
1523 WARNING: Since the result is floating point, it may not be exact.
1524 Do not use this function if precise time stamps are required. */)
1526 Lisp_Object specified_time
;
1531 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1532 error ("Invalid time specification");
1534 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1537 /* Write information into buffer S of size MAXSIZE, according to the
1538 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1539 Default to Universal Time if UT is nonzero, local time otherwise.
1540 Return the number of bytes written, not including the terminating
1541 '\0'. If S is NULL, nothing will be written anywhere; so to
1542 determine how many bytes would be written, use NULL for S and
1543 ((size_t) -1) for MAXSIZE.
1545 This function behaves like emacs_strftimeu, except it allows null
1548 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1553 const struct tm
*tp
;
1558 /* Loop through all the null-terminated strings in the format
1559 argument. Normally there's just one null-terminated string, but
1560 there can be arbitrarily many, concatenated together, if the
1561 format contains '\0' bytes. emacs_strftimeu stops at the first
1562 '\0' byte so we must invoke it separately for each such string. */
1571 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1575 if (result
== 0 && s
[0] != '\0')
1580 maxsize
-= result
+ 1;
1582 len
= strlen (format
);
1583 if (len
== format_len
)
1587 format_len
-= len
+ 1;
1591 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1592 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1593 TIME is specified as (HIGH LOW . IGNORED), as returned by
1594 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1595 is also still accepted.
1596 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1597 as Universal Time; nil means describe TIME in the local time zone.
1598 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1599 by text that describes the specified date and time in TIME:
1601 %Y is the year, %y within the century, %C the century.
1602 %G is the year corresponding to the ISO week, %g within the century.
1603 %m is the numeric month.
1604 %b and %h are the locale's abbreviated month name, %B the full name.
1605 %d is the day of the month, zero-padded, %e is blank-padded.
1606 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1607 %a is the locale's abbreviated name of the day of week, %A the full name.
1608 %U is the week number starting on Sunday, %W starting on Monday,
1609 %V according to ISO 8601.
1610 %j is the day of the year.
1612 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1613 only blank-padded, %l is like %I blank-padded.
1614 %p is the locale's equivalent of either AM or PM.
1617 %Z is the time zone name, %z is the numeric form.
1618 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1620 %c is the locale's date and time format.
1621 %x is the locale's "preferred" date format.
1622 %D is like "%m/%d/%y".
1624 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1625 %X is the locale's "preferred" time format.
1627 Finally, %n is a newline, %t is a tab, %% is a literal %.
1629 Certain flags and modifiers are available with some format controls.
1630 The flags are `_', `-', `^' and `#'. For certain characters X,
1631 %_X is like %X, but padded with blanks; %-X is like %X,
1632 but without padding. %^X is like %X, but with all textual
1633 characters up-cased; %#X is like %X, but with letter-case of
1634 all textual characters reversed.
1635 %NX (where N stands for an integer) is like %X,
1636 but takes up at least N (a number) positions.
1637 The modifiers are `E' and `O'. For certain characters X,
1638 %EX is a locale's alternative version of %X;
1639 %OX is like %X, but uses the locale's number symbols.
1641 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1642 (format_string
, time
, universal
)
1643 Lisp_Object format_string
, time
, universal
;
1648 int ut
= ! NILP (universal
);
1650 CHECK_STRING (format_string
);
1652 if (! lisp_time_argument (time
, &value
, NULL
))
1653 error ("Invalid time specification");
1655 format_string
= code_convert_string_norecord (format_string
,
1656 Vlocale_coding_system
, 1);
1658 /* This is probably enough. */
1659 size
= SBYTES (format_string
) * 6 + 50;
1661 tm
= ut
? gmtime (&value
) : localtime (&value
);
1663 error ("Specified time is not representable");
1665 synchronize_system_time_locale ();
1669 char *buf
= (char *) alloca (size
+ 1);
1673 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1674 SBYTES (format_string
),
1676 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1677 return code_convert_string_norecord (make_string (buf
, result
),
1678 Vlocale_coding_system
, 0);
1680 /* If buffer was too small, make it bigger and try again. */
1681 result
= emacs_memftimeu (NULL
, (size_t) -1,
1682 SDATA (format_string
),
1683 SBYTES (format_string
),
1689 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1690 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1691 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1692 as from `current-time' and `file-attributes', or `nil' to use the
1693 current time. The obsolete form (HIGH . LOW) is also still accepted.
1694 The list has the following nine members: SEC is an integer between 0
1695 and 60; SEC is 60 for a leap second, which only some operating systems
1696 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1697 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1698 integer between 1 and 12. YEAR is an integer indicating the
1699 four-digit year. DOW is the day of week, an integer between 0 and 6,
1700 where 0 is Sunday. DST is t if daylight savings time is effect,
1701 otherwise nil. ZONE is an integer indicating the number of seconds
1702 east of Greenwich. (Note that Common Lisp has different meanings for
1705 Lisp_Object specified_time
;
1709 struct tm
*decoded_time
;
1710 Lisp_Object list_args
[9];
1712 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1713 error ("Invalid time specification");
1715 decoded_time
= localtime (&time_spec
);
1717 error ("Specified time is not representable");
1718 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1719 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1720 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1721 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1722 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1723 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1724 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1725 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1727 /* Make a copy, in case gmtime modifies the struct. */
1728 save_tm
= *decoded_time
;
1729 decoded_time
= gmtime (&time_spec
);
1730 if (decoded_time
== 0)
1731 list_args
[8] = Qnil
;
1733 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1734 return Flist (9, list_args
);
1737 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1738 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1739 This is the reverse operation of `decode-time', which see.
1740 ZONE defaults to the current time zone rule. This can
1741 be a string or t (as from `set-time-zone-rule'), or it can be a list
1742 \(as from `current-time-zone') or an integer (as from `decode-time')
1743 applied without consideration for daylight savings time.
1745 You can pass more than 7 arguments; then the first six arguments
1746 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1747 The intervening arguments are ignored.
1748 This feature lets (apply 'encode-time (decode-time ...)) work.
1750 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1751 for example, a DAY of 0 means the day preceding the given month.
1752 Year numbers less than 100 are treated just like other year numbers.
1753 If you want them to stand for years in this century, you must do that yourself.
1755 Years before 1970 are not guaranteed to work. On some systems,
1756 year values as low as 1901 do work.
1758 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1761 register Lisp_Object
*args
;
1765 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1767 CHECK_NUMBER (args
[0]); /* second */
1768 CHECK_NUMBER (args
[1]); /* minute */
1769 CHECK_NUMBER (args
[2]); /* hour */
1770 CHECK_NUMBER (args
[3]); /* day */
1771 CHECK_NUMBER (args
[4]); /* month */
1772 CHECK_NUMBER (args
[5]); /* year */
1774 tm
.tm_sec
= XINT (args
[0]);
1775 tm
.tm_min
= XINT (args
[1]);
1776 tm
.tm_hour
= XINT (args
[2]);
1777 tm
.tm_mday
= XINT (args
[3]);
1778 tm
.tm_mon
= XINT (args
[4]) - 1;
1779 tm
.tm_year
= XINT (args
[5]) - 1900;
1785 time
= mktime (&tm
);
1790 char **oldenv
= environ
, **newenv
;
1794 else if (STRINGP (zone
))
1795 tzstring
= (char *) SDATA (zone
);
1796 else if (INTEGERP (zone
))
1798 int abszone
= abs (XINT (zone
));
1799 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1800 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1804 error ("Invalid time zone specification");
1806 /* Set TZ before calling mktime; merely adjusting mktime's returned
1807 value doesn't suffice, since that would mishandle leap seconds. */
1808 set_time_zone_rule (tzstring
);
1810 time
= mktime (&tm
);
1812 /* Restore TZ to previous value. */
1816 #ifdef LOCALTIME_CACHE
1821 if (time
== (time_t) -1)
1822 error ("Specified time is not representable");
1824 return make_time (time
);
1827 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1828 doc
: /* Return the current time, as a human-readable string.
1829 Programs can use this function to decode a time,
1830 since the number of columns in each field is fixed.
1831 The format is `Sun Sep 16 01:03:52 1973'.
1832 However, see also the functions `decode-time' and `format-time-string'
1833 which provide a much more powerful and general facility.
1835 If SPECIFIED-TIME is given, it is a time to format instead of the
1836 current time. The argument should have the form (HIGH LOW . IGNORED).
1837 Thus, you can use times obtained from `current-time' and from
1838 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1839 but this is considered obsolete. */)
1841 Lisp_Object specified_time
;
1847 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1849 tem
= (char *) ctime (&value
);
1851 strncpy (buf
, tem
, 24);
1854 return build_string (buf
);
1857 #define TM_YEAR_BASE 1900
1859 /* Yield A - B, measured in seconds.
1860 This function is copied from the GNU C Library. */
1865 /* Compute intervening leap days correctly even if year is negative.
1866 Take care to avoid int overflow in leap day calculations,
1867 but it's OK to assume that A and B are close to each other. */
1868 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1869 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1870 int a100
= a4
/ 25 - (a4
% 25 < 0);
1871 int b100
= b4
/ 25 - (b4
% 25 < 0);
1872 int a400
= a100
>> 2;
1873 int b400
= b100
>> 2;
1874 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1875 int years
= a
->tm_year
- b
->tm_year
;
1876 int days
= (365 * years
+ intervening_leap_days
1877 + (a
->tm_yday
- b
->tm_yday
));
1878 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1879 + (a
->tm_min
- b
->tm_min
))
1880 + (a
->tm_sec
- b
->tm_sec
));
1883 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1884 doc
: /* Return the offset and name for the local time zone.
1885 This returns a list of the form (OFFSET NAME).
1886 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1887 A negative value means west of Greenwich.
1888 NAME is a string giving the name of the time zone.
1889 If SPECIFIED-TIME is given, the time zone offset is determined from it
1890 instead of using the current time. The argument should have the form
1891 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1892 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1893 have the form (HIGH . LOW), but this is considered obsolete.
1895 Some operating systems cannot provide all this information to Emacs;
1896 in this case, `current-time-zone' returns a list containing nil for
1897 the data it can't find. */)
1899 Lisp_Object specified_time
;
1905 if (lisp_time_argument (specified_time
, &value
, NULL
)
1906 && (t
= gmtime (&value
)) != 0
1907 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1909 int offset
= tm_diff (t
, &gmt
);
1914 s
= (char *)t
->tm_zone
;
1915 #else /* not HAVE_TM_ZONE */
1917 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1918 s
= tzname
[t
->tm_isdst
];
1920 #endif /* not HAVE_TM_ZONE */
1922 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1925 /* On Japanese w32, we can get a Japanese string as time
1926 zone name. Don't accept that. */
1928 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1937 /* No local time zone name is available; use "+-NNNN" instead. */
1938 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1939 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1942 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1945 return Fmake_list (make_number (2), Qnil
);
1948 /* This holds the value of `environ' produced by the previous
1949 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1950 has never been called. */
1951 static char **environbuf
;
1953 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1954 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1955 If TZ is nil, use implementation-defined default time zone information.
1956 If TZ is t, use Universal Time. */)
1964 else if (EQ (tz
, Qt
))
1969 tzstring
= (char *) SDATA (tz
);
1972 set_time_zone_rule (tzstring
);
1975 environbuf
= environ
;
1980 #ifdef LOCALTIME_CACHE
1982 /* These two values are known to load tz files in buggy implementations,
1983 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1984 Their values shouldn't matter in non-buggy implementations.
1985 We don't use string literals for these strings,
1986 since if a string in the environment is in readonly
1987 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1988 See Sun bugs 1113095 and 1114114, ``Timezone routines
1989 improperly modify environment''. */
1991 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1992 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1996 /* Set the local time zone rule to TZSTRING.
1997 This allocates memory into `environ', which it is the caller's
1998 responsibility to free. */
2001 set_time_zone_rule (tzstring
)
2005 char **from
, **to
, **newenv
;
2007 /* Make the ENVIRON vector longer with room for TZSTRING. */
2008 for (from
= environ
; *from
; from
++)
2010 envptrs
= from
- environ
+ 2;
2011 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
2012 + (tzstring
? strlen (tzstring
) + 4 : 0));
2014 /* Add TZSTRING to the end of environ, as a value for TZ. */
2017 char *t
= (char *) (to
+ envptrs
);
2019 strcat (t
, tzstring
);
2023 /* Copy the old environ vector elements into NEWENV,
2024 but don't copy the TZ variable.
2025 So we have only one definition of TZ, which came from TZSTRING. */
2026 for (from
= environ
; *from
; from
++)
2027 if (strncmp (*from
, "TZ=", 3) != 0)
2033 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2034 the TZ variable is stored. If we do not have a TZSTRING,
2035 TO points to the vector slot which has the terminating null. */
2037 #ifdef LOCALTIME_CACHE
2039 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2040 "US/Pacific" that loads a tz file, then changes to a value like
2041 "XXX0" that does not load a tz file, and then changes back to
2042 its original value, the last change is (incorrectly) ignored.
2043 Also, if TZ changes twice in succession to values that do
2044 not load a tz file, tzset can dump core (see Sun bug#1225179).
2045 The following code works around these bugs. */
2049 /* Temporarily set TZ to a value that loads a tz file
2050 and that differs from tzstring. */
2052 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2053 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2059 /* The implied tzstring is unknown, so temporarily set TZ to
2060 two different values that each load a tz file. */
2061 *to
= set_time_zone_rule_tz1
;
2064 *to
= set_time_zone_rule_tz2
;
2069 /* Now TZ has the desired value, and tzset can be invoked safely. */
2076 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2077 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2078 type of object is Lisp_String). INHERIT is passed to
2079 INSERT_FROM_STRING_FUNC as the last argument. */
2082 general_insert_function (insert_func
, insert_from_string_func
,
2083 inherit
, nargs
, args
)
2084 void (*insert_func
) P_ ((const unsigned char *, int));
2085 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2087 register Lisp_Object
*args
;
2089 register int argnum
;
2090 register Lisp_Object val
;
2092 for (argnum
= 0; argnum
< nargs
; argnum
++)
2098 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2101 if (!NILP (current_buffer
->enable_multibyte_characters
))
2102 len
= CHAR_STRING (XFASTINT (val
), str
);
2105 str
[0] = (ASCII_CHAR_P (XINT (val
))
2107 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2110 (*insert_func
) (str
, len
);
2112 else if (STRINGP (val
))
2114 (*insert_from_string_func
) (val
, 0, 0,
2121 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2135 /* Callers passing one argument to Finsert need not gcpro the
2136 argument "array", since the only element of the array will
2137 not be used after calling insert or insert_from_string, so
2138 we don't care if it gets trashed. */
2140 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2141 doc
: /* Insert the arguments, either strings or characters, at point.
2142 Point and before-insertion markers move forward to end up
2143 after the inserted text.
2144 Any other markers at the point of insertion remain before the text.
2146 If the current buffer is multibyte, unibyte strings are converted
2147 to multibyte for insertion (see `string-make-multibyte').
2148 If the current buffer is unibyte, multibyte strings are converted
2149 to unibyte for insertion (see `string-make-unibyte').
2151 When operating on binary data, it may be necessary to preserve the
2152 original bytes of a unibyte string when inserting it into a multibyte
2153 buffer; to accomplish this, apply `string-as-multibyte' to the string
2154 and insert the result.
2156 usage: (insert &rest ARGS) */)
2159 register Lisp_Object
*args
;
2161 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2165 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2167 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2168 Point and before-insertion markers move forward to end up
2169 after the inserted text.
2170 Any other markers at the point of insertion remain before the text.
2172 If the current buffer is multibyte, unibyte strings are converted
2173 to multibyte for insertion (see `unibyte-char-to-multibyte').
2174 If the current buffer is unibyte, multibyte strings are converted
2175 to unibyte for insertion.
2177 usage: (insert-and-inherit &rest ARGS) */)
2180 register Lisp_Object
*args
;
2182 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2187 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2188 doc
: /* Insert strings or characters at point, relocating markers after the text.
2189 Point and markers move forward to end up after the inserted text.
2191 If the current buffer is multibyte, unibyte strings are converted
2192 to multibyte for insertion (see `unibyte-char-to-multibyte').
2193 If the current buffer is unibyte, multibyte strings are converted
2194 to unibyte for insertion.
2196 usage: (insert-before-markers &rest ARGS) */)
2199 register Lisp_Object
*args
;
2201 general_insert_function (insert_before_markers
,
2202 insert_from_string_before_markers
, 0,
2207 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2208 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2209 doc
: /* Insert text at point, relocating markers and inheriting properties.
2210 Point and markers move forward to end up after the inserted text.
2212 If the current buffer is multibyte, unibyte strings are converted
2213 to multibyte for insertion (see `unibyte-char-to-multibyte').
2214 If the current buffer is unibyte, multibyte strings are converted
2215 to unibyte for insertion.
2217 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2220 register Lisp_Object
*args
;
2222 general_insert_function (insert_before_markers_and_inherit
,
2223 insert_from_string_before_markers
, 1,
2228 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2229 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2230 Both arguments are required.
2231 Point, and before-insertion markers, are relocated as in the function `insert'.
2232 The optional third arg INHERIT, if non-nil, says to inherit text properties
2233 from adjoining text, if those properties are sticky. */)
2234 (character
, count
, inherit
)
2235 Lisp_Object character
, count
, inherit
;
2237 register unsigned char *string
;
2238 register int strlen
;
2241 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2243 CHECK_NUMBER (character
);
2244 CHECK_NUMBER (count
);
2246 if (!NILP (current_buffer
->enable_multibyte_characters
))
2247 len
= CHAR_STRING (XFASTINT (character
), str
);
2249 str
[0] = XFASTINT (character
), len
= 1;
2250 n
= XINT (count
) * len
;
2253 strlen
= min (n
, 256 * len
);
2254 string
= (unsigned char *) alloca (strlen
);
2255 for (i
= 0; i
< strlen
; i
++)
2256 string
[i
] = str
[i
% len
];
2260 if (!NILP (inherit
))
2261 insert_and_inherit (string
, strlen
);
2263 insert (string
, strlen
);
2268 if (!NILP (inherit
))
2269 insert_and_inherit (string
, n
);
2276 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2277 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2278 Both arguments are required.
2279 BYTE is a number of the range 0..255.
2281 If BYTE is 128..255 and the current buffer is multibyte, the
2282 corresponding eight-bit character is inserted.
2284 Point, and before-insertion markers, are relocated as in the function `insert'.
2285 The optional third arg INHERIT, if non-nil, says to inherit text properties
2286 from adjoining text, if those properties are sticky. */)
2287 (byte
, count
, inherit
)
2288 Lisp_Object byte
, count
, inherit
;
2290 CHECK_NUMBER (byte
);
2291 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2292 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2293 if (XINT (byte
) >= 128
2294 && ! NILP (current_buffer
->enable_multibyte_characters
))
2295 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2296 return Finsert_char (byte
, count
, inherit
);
2300 /* Making strings from buffer contents. */
2302 /* Return a Lisp_String containing the text of the current buffer from
2303 START to END. If text properties are in use and the current buffer
2304 has properties in the range specified, the resulting string will also
2305 have them, if PROPS is nonzero.
2307 We don't want to use plain old make_string here, because it calls
2308 make_uninit_string, which can cause the buffer arena to be
2309 compacted. make_string has no way of knowing that the data has
2310 been moved, and thus copies the wrong data into the string. This
2311 doesn't effect most of the other users of make_string, so it should
2312 be left as is. But we should use this function when conjuring
2313 buffer substrings. */
2316 make_buffer_string (start
, end
, props
)
2320 int start_byte
= CHAR_TO_BYTE (start
);
2321 int end_byte
= CHAR_TO_BYTE (end
);
2323 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2326 /* Return a Lisp_String containing the text of the current buffer from
2327 START / START_BYTE to END / END_BYTE.
2329 If text properties are in use and the current buffer
2330 has properties in the range specified, the resulting string will also
2331 have them, if PROPS is nonzero.
2333 We don't want to use plain old make_string here, because it calls
2334 make_uninit_string, which can cause the buffer arena to be
2335 compacted. make_string has no way of knowing that the data has
2336 been moved, and thus copies the wrong data into the string. This
2337 doesn't effect most of the other users of make_string, so it should
2338 be left as is. But we should use this function when conjuring
2339 buffer substrings. */
2342 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2343 int start
, start_byte
, end
, end_byte
;
2346 Lisp_Object result
, tem
, tem1
;
2348 if (start
< GPT
&& GPT
< end
)
2351 if (! NILP (current_buffer
->enable_multibyte_characters
))
2352 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2354 result
= make_uninit_string (end
- start
);
2355 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2356 end_byte
- start_byte
);
2358 /* If desired, update and copy the text properties. */
2361 update_buffer_properties (start
, end
);
2363 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2364 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2366 if (XINT (tem
) != end
|| !NILP (tem1
))
2367 copy_intervals_to_string (result
, current_buffer
, start
,
2374 /* Call Vbuffer_access_fontify_functions for the range START ... END
2375 in the current buffer, if necessary. */
2378 update_buffer_properties (start
, end
)
2381 /* If this buffer has some access functions,
2382 call them, specifying the range of the buffer being accessed. */
2383 if (!NILP (Vbuffer_access_fontify_functions
))
2385 Lisp_Object args
[3];
2388 args
[0] = Qbuffer_access_fontify_functions
;
2389 XSETINT (args
[1], start
);
2390 XSETINT (args
[2], end
);
2392 /* But don't call them if we can tell that the work
2393 has already been done. */
2394 if (!NILP (Vbuffer_access_fontified_property
))
2396 tem
= Ftext_property_any (args
[1], args
[2],
2397 Vbuffer_access_fontified_property
,
2400 Frun_hook_with_args (3, args
);
2403 Frun_hook_with_args (3, args
);
2407 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2408 doc
: /* Return the contents of part of the current buffer as a string.
2409 The two arguments START and END are character positions;
2410 they can be in either order.
2411 The string returned is multibyte if the buffer is multibyte.
2413 This function copies the text properties of that part of the buffer
2414 into the result string; if you don't want the text properties,
2415 use `buffer-substring-no-properties' instead. */)
2417 Lisp_Object start
, end
;
2421 validate_region (&start
, &end
);
2425 return make_buffer_string (b
, e
, 1);
2428 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2429 Sbuffer_substring_no_properties
, 2, 2, 0,
2430 doc
: /* Return the characters of part of the buffer, without the text properties.
2431 The two arguments START and END are character positions;
2432 they can be in either order. */)
2434 Lisp_Object start
, end
;
2438 validate_region (&start
, &end
);
2442 return make_buffer_string (b
, e
, 0);
2445 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2446 doc
: /* Return the contents of the current buffer as a string.
2447 If narrowing is in effect, this function returns only the visible part
2451 return make_buffer_string (BEGV
, ZV
, 1);
2454 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2456 doc
: /* Insert before point a substring of the contents of BUFFER.
2457 BUFFER may be a buffer or a buffer name.
2458 Arguments START and END are character positions specifying the substring.
2459 They default to the values of (point-min) and (point-max) in BUFFER. */)
2460 (buffer
, start
, end
)
2461 Lisp_Object buffer
, start
, end
;
2463 register int b
, e
, temp
;
2464 register struct buffer
*bp
, *obuf
;
2467 buf
= Fget_buffer (buffer
);
2471 if (NILP (bp
->name
))
2472 error ("Selecting deleted buffer");
2478 CHECK_NUMBER_COERCE_MARKER (start
);
2485 CHECK_NUMBER_COERCE_MARKER (end
);
2490 temp
= b
, b
= e
, e
= temp
;
2492 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2493 args_out_of_range (start
, end
);
2495 obuf
= current_buffer
;
2496 set_buffer_internal_1 (bp
);
2497 update_buffer_properties (b
, e
);
2498 set_buffer_internal_1 (obuf
);
2500 insert_from_buffer (bp
, b
, e
- b
, 0);
2504 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2506 doc
: /* Compare two substrings of two buffers; return result as number.
2507 the value is -N if first string is less after N-1 chars,
2508 +N if first string is greater after N-1 chars, or 0 if strings match.
2509 Each substring is represented as three arguments: BUFFER, START and END.
2510 That makes six args in all, three for each substring.
2512 The value of `case-fold-search' in the current buffer
2513 determines whether case is significant or ignored. */)
2514 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2515 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2517 register int begp1
, endp1
, begp2
, endp2
, temp
;
2518 register struct buffer
*bp1
, *bp2
;
2519 register Lisp_Object trt
2520 = (!NILP (current_buffer
->case_fold_search
)
2521 ? current_buffer
->case_canon_table
: Qnil
);
2523 int i1
, i2
, i1_byte
, i2_byte
;
2525 /* Find the first buffer and its substring. */
2528 bp1
= current_buffer
;
2532 buf1
= Fget_buffer (buffer1
);
2535 bp1
= XBUFFER (buf1
);
2536 if (NILP (bp1
->name
))
2537 error ("Selecting deleted buffer");
2541 begp1
= BUF_BEGV (bp1
);
2544 CHECK_NUMBER_COERCE_MARKER (start1
);
2545 begp1
= XINT (start1
);
2548 endp1
= BUF_ZV (bp1
);
2551 CHECK_NUMBER_COERCE_MARKER (end1
);
2552 endp1
= XINT (end1
);
2556 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2558 if (!(BUF_BEGV (bp1
) <= begp1
2560 && endp1
<= BUF_ZV (bp1
)))
2561 args_out_of_range (start1
, end1
);
2563 /* Likewise for second substring. */
2566 bp2
= current_buffer
;
2570 buf2
= Fget_buffer (buffer2
);
2573 bp2
= XBUFFER (buf2
);
2574 if (NILP (bp2
->name
))
2575 error ("Selecting deleted buffer");
2579 begp2
= BUF_BEGV (bp2
);
2582 CHECK_NUMBER_COERCE_MARKER (start2
);
2583 begp2
= XINT (start2
);
2586 endp2
= BUF_ZV (bp2
);
2589 CHECK_NUMBER_COERCE_MARKER (end2
);
2590 endp2
= XINT (end2
);
2594 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2596 if (!(BUF_BEGV (bp2
) <= begp2
2598 && endp2
<= BUF_ZV (bp2
)))
2599 args_out_of_range (start2
, end2
);
2603 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2604 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2606 while (i1
< endp1
&& i2
< endp2
)
2608 /* When we find a mismatch, we must compare the
2609 characters, not just the bytes. */
2614 if (! NILP (bp1
->enable_multibyte_characters
))
2616 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2617 BUF_INC_POS (bp1
, i1_byte
);
2622 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2623 c1
= unibyte_char_to_multibyte (c1
);
2627 if (! NILP (bp2
->enable_multibyte_characters
))
2629 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2630 BUF_INC_POS (bp2
, i2_byte
);
2635 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2636 c2
= unibyte_char_to_multibyte (c2
);
2642 c1
= CHAR_TABLE_TRANSLATE (trt
, c1
);
2643 c2
= CHAR_TABLE_TRANSLATE (trt
, c2
);
2646 return make_number (- 1 - chars
);
2648 return make_number (chars
+ 1);
2653 /* The strings match as far as they go.
2654 If one is shorter, that one is less. */
2655 if (chars
< endp1
- begp1
)
2656 return make_number (chars
+ 1);
2657 else if (chars
< endp2
- begp2
)
2658 return make_number (- chars
- 1);
2660 /* Same length too => they are equal. */
2661 return make_number (0);
2665 subst_char_in_region_unwind (arg
)
2668 return current_buffer
->undo_list
= arg
;
2672 subst_char_in_region_unwind_1 (arg
)
2675 return current_buffer
->filename
= arg
;
2678 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2679 Ssubst_char_in_region
, 4, 5, 0,
2680 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2681 If optional arg NOUNDO is non-nil, don't record this change for undo
2682 and don't mark the buffer as really changed.
2683 Both characters must have the same length of multi-byte form. */)
2684 (start
, end
, fromchar
, tochar
, noundo
)
2685 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2687 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2689 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2691 int count
= SPECPDL_INDEX ();
2692 #define COMBINING_NO 0
2693 #define COMBINING_BEFORE 1
2694 #define COMBINING_AFTER 2
2695 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2696 int maybe_byte_combining
= COMBINING_NO
;
2697 int last_changed
= 0;
2698 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2700 validate_region (&start
, &end
);
2701 CHECK_NUMBER (fromchar
);
2702 CHECK_NUMBER (tochar
);
2706 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2707 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2708 error ("Characters in `subst-char-in-region' have different byte-lengths");
2709 if (!ASCII_BYTE_P (*tostr
))
2711 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2712 complete multibyte character, it may be combined with the
2713 after bytes. If it is in the range 0xA0..0xFF, it may be
2714 combined with the before and after bytes. */
2715 if (!CHAR_HEAD_P (*tostr
))
2716 maybe_byte_combining
= COMBINING_BOTH
;
2717 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2718 maybe_byte_combining
= COMBINING_AFTER
;
2724 fromstr
[0] = XFASTINT (fromchar
);
2725 tostr
[0] = XFASTINT (tochar
);
2729 pos_byte
= CHAR_TO_BYTE (pos
);
2730 stop
= CHAR_TO_BYTE (XINT (end
));
2733 /* If we don't want undo, turn off putting stuff on the list.
2734 That's faster than getting rid of things,
2735 and it prevents even the entry for a first change.
2736 Also inhibit locking the file. */
2739 record_unwind_protect (subst_char_in_region_unwind
,
2740 current_buffer
->undo_list
);
2741 current_buffer
->undo_list
= Qt
;
2742 /* Don't do file-locking. */
2743 record_unwind_protect (subst_char_in_region_unwind_1
,
2744 current_buffer
->filename
);
2745 current_buffer
->filename
= Qnil
;
2748 if (pos_byte
< GPT_BYTE
)
2749 stop
= min (stop
, GPT_BYTE
);
2752 int pos_byte_next
= pos_byte
;
2754 if (pos_byte
>= stop
)
2756 if (pos_byte
>= end_byte
) break;
2759 p
= BYTE_POS_ADDR (pos_byte
);
2761 INC_POS (pos_byte_next
);
2764 if (pos_byte_next
- pos_byte
== len
2765 && p
[0] == fromstr
[0]
2767 || (p
[1] == fromstr
[1]
2768 && (len
== 2 || (p
[2] == fromstr
[2]
2769 && (len
== 3 || p
[3] == fromstr
[3]))))))
2774 modify_region (current_buffer
, changed
, XINT (end
));
2776 if (! NILP (noundo
))
2778 if (MODIFF
- 1 == SAVE_MODIFF
)
2780 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2781 current_buffer
->auto_save_modified
++;
2785 /* Take care of the case where the new character
2786 combines with neighboring bytes. */
2787 if (maybe_byte_combining
2788 && (maybe_byte_combining
== COMBINING_AFTER
2789 ? (pos_byte_next
< Z_BYTE
2790 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2791 : ((pos_byte_next
< Z_BYTE
2792 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2793 || (pos_byte
> BEG_BYTE
2794 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2796 Lisp_Object tem
, string
;
2798 struct gcpro gcpro1
;
2800 tem
= current_buffer
->undo_list
;
2803 /* Make a multibyte string containing this single character. */
2804 string
= make_multibyte_string (tostr
, 1, len
);
2805 /* replace_range is less efficient, because it moves the gap,
2806 but it handles combining correctly. */
2807 replace_range (pos
, pos
+ 1, string
,
2809 pos_byte_next
= CHAR_TO_BYTE (pos
);
2810 if (pos_byte_next
> pos_byte
)
2811 /* Before combining happened. We should not increment
2812 POS. So, to cancel the later increment of POS,
2816 INC_POS (pos_byte_next
);
2818 if (! NILP (noundo
))
2819 current_buffer
->undo_list
= tem
;
2826 record_change (pos
, 1);
2827 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2829 last_changed
= pos
+ 1;
2831 pos_byte
= pos_byte_next
;
2837 signal_after_change (changed
,
2838 last_changed
- changed
, last_changed
- changed
);
2839 update_compositions (changed
, last_changed
, CHECK_ALL
);
2842 unbind_to (count
, Qnil
);
2847 static Lisp_Object check_translation
P_ ((int, int, int, Lisp_Object
));
2849 /* Helper function for Ftranslate_region_internal.
2851 Check if a character sequence at POS (POS_BYTE) matches an element
2852 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2853 element is found, return it. Otherwise return Qnil. */
2856 check_translation (pos
, pos_byte
, end
, val
)
2857 int pos
, pos_byte
, end
;
2860 int buf_size
= 16, buf_used
= 0;
2861 int *buf
= alloca (sizeof (int) * buf_size
);
2863 for (; CONSP (val
); val
= XCDR (val
))
2872 if (! VECTORP (elt
))
2875 if (len
<= end
- pos
)
2877 for (i
= 0; i
< len
; i
++)
2881 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2884 if (buf_used
== buf_size
)
2889 newbuf
= alloca (sizeof (int) * buf_size
);
2890 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2893 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, 0, len
);
2896 if (XINT (AREF (elt
, i
)) != buf
[i
])
2907 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2908 Stranslate_region_internal
, 3, 3, 0,
2909 doc
: /* Internal use only.
2910 From START to END, translate characters according to TABLE.
2911 TABLE is a string or a char-table; the Nth character in it is the
2912 mapping for the character with code N.
2913 It returns the number of characters changed. */)
2917 register Lisp_Object table
;
2919 register unsigned char *tt
; /* Trans table. */
2920 register int nc
; /* New character. */
2921 int cnt
; /* Number of changes made. */
2922 int size
; /* Size of translate table. */
2923 int pos
, pos_byte
, end_pos
;
2924 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2925 int string_multibyte
;
2928 validate_region (&start
, &end
);
2929 if (CHAR_TABLE_P (table
))
2931 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
2932 error ("Not a translation table");
2938 CHECK_STRING (table
);
2940 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2941 table
= string_make_unibyte (table
);
2942 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2943 size
= SBYTES (table
);
2948 pos_byte
= CHAR_TO_BYTE (pos
);
2949 end_pos
= XINT (end
);
2950 modify_region (current_buffer
, pos
, end_pos
);
2953 for (; pos
< end_pos
; )
2955 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2956 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2962 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2969 /* Reload as signal_after_change in last iteration may GC. */
2971 if (string_multibyte
)
2973 str
= tt
+ string_char_to_byte (table
, oc
);
2974 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2980 if (! ASCII_BYTE_P (nc
) && multibyte
)
2982 str_len
= BYTE8_STRING (nc
, buf
);
2997 val
= CHAR_TABLE_REF (table
, oc
);
2998 if (CHARACTERP (val
)
2999 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
3002 str_len
= CHAR_STRING (nc
, buf
);
3005 else if (VECTORP (val
) || (CONSP (val
)))
3007 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3008 where TO is TO-CHAR or [TO-CHAR ...]. */
3013 if (nc
!= oc
&& nc
>= 0)
3015 /* Simple one char to one char translation. */
3020 /* This is less efficient, because it moves the gap,
3021 but it should handle multibyte characters correctly. */
3022 string
= make_multibyte_string (str
, 1, str_len
);
3023 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3028 record_change (pos
, 1);
3029 while (str_len
-- > 0)
3031 signal_after_change (pos
, 1, 1);
3032 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3042 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3049 /* VAL is ([FROM-CHAR ...] . TO). */
3050 len
= ASIZE (XCAR (val
));
3060 string
= Fmake_string (make_number (ASIZE (val
)),
3062 for (i
= 1; i
< ASIZE (val
); i
++)
3063 Faset (string
, make_number (i
), AREF (val
, i
));
3067 string
= Fmake_string (make_number (1), val
);
3069 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3070 pos_byte
+= SBYTES (string
);
3071 pos
+= SCHARS (string
);
3072 cnt
+= SCHARS (string
);
3073 end_pos
+= SCHARS (string
) - len
;
3081 return make_number (cnt
);
3084 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3085 doc
: /* Delete the text between point and mark.
3087 When called from a program, expects two arguments,
3088 positions (integers or markers) specifying the stretch to be deleted. */)
3090 Lisp_Object start
, end
;
3092 validate_region (&start
, &end
);
3093 del_range (XINT (start
), XINT (end
));
3097 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3098 Sdelete_and_extract_region
, 2, 2, 0,
3099 doc
: /* Delete the text between START and END and return it. */)
3101 Lisp_Object start
, end
;
3103 validate_region (&start
, &end
);
3104 if (XINT (start
) == XINT (end
))
3105 return build_string ("");
3106 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3109 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3110 doc
: /* Remove restrictions (narrowing) from current buffer.
3111 This allows the buffer's full text to be seen and edited. */)
3114 if (BEG
!= BEGV
|| Z
!= ZV
)
3115 current_buffer
->clip_changed
= 1;
3117 BEGV_BYTE
= BEG_BYTE
;
3118 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3119 /* Changing the buffer bounds invalidates any recorded current column. */
3120 invalidate_current_column ();
3124 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3125 doc
: /* Restrict editing in this buffer to the current region.
3126 The rest of the text becomes temporarily invisible and untouchable
3127 but is not deleted; if you save the buffer in a file, the invisible
3128 text is included in the file. \\[widen] makes all visible again.
3129 See also `save-restriction'.
3131 When calling from a program, pass two arguments; positions (integers
3132 or markers) bounding the text that should remain visible. */)
3134 register Lisp_Object start
, end
;
3136 CHECK_NUMBER_COERCE_MARKER (start
);
3137 CHECK_NUMBER_COERCE_MARKER (end
);
3139 if (XINT (start
) > XINT (end
))
3142 tem
= start
; start
= end
; end
= tem
;
3145 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3146 args_out_of_range (start
, end
);
3148 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3149 current_buffer
->clip_changed
= 1;
3151 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3152 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3153 if (PT
< XFASTINT (start
))
3154 SET_PT (XFASTINT (start
));
3155 if (PT
> XFASTINT (end
))
3156 SET_PT (XFASTINT (end
));
3157 /* Changing the buffer bounds invalidates any recorded current column. */
3158 invalidate_current_column ();
3163 save_restriction_save ()
3165 if (BEGV
== BEG
&& ZV
== Z
)
3166 /* The common case that the buffer isn't narrowed.
3167 We return just the buffer object, which save_restriction_restore
3168 recognizes as meaning `no restriction'. */
3169 return Fcurrent_buffer ();
3171 /* We have to save a restriction, so return a pair of markers, one
3172 for the beginning and one for the end. */
3174 Lisp_Object beg
, end
;
3176 beg
= buildmark (BEGV
, BEGV_BYTE
);
3177 end
= buildmark (ZV
, ZV_BYTE
);
3179 /* END must move forward if text is inserted at its exact location. */
3180 XMARKER(end
)->insertion_type
= 1;
3182 return Fcons (beg
, end
);
3187 save_restriction_restore (data
)
3191 /* A pair of marks bounding a saved restriction. */
3193 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3194 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3195 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3197 if (buf
/* Verify marker still points to a buffer. */
3198 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3199 /* The restriction has changed from the saved one, so restore
3200 the saved restriction. */
3202 int pt
= BUF_PT (buf
);
3204 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3205 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3207 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3208 /* The point is outside the new visible range, move it inside. */
3209 SET_BUF_PT_BOTH (buf
,
3210 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3211 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3214 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3218 /* A buffer, which means that there was no old restriction. */
3220 struct buffer
*buf
= XBUFFER (data
);
3222 if (buf
/* Verify marker still points to a buffer. */
3223 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3224 /* The buffer has been narrowed, get rid of the narrowing. */
3226 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3227 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3229 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3236 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3237 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3238 The buffer's restrictions make parts of the beginning and end invisible.
3239 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3240 This special form, `save-restriction', saves the current buffer's restrictions
3241 when it is entered, and restores them when it is exited.
3242 So any `narrow-to-region' within BODY lasts only until the end of the form.
3243 The old restrictions settings are restored
3244 even in case of abnormal exit (throw or error).
3246 The value returned is the value of the last form in BODY.
3248 Note: if you are using both `save-excursion' and `save-restriction',
3249 use `save-excursion' outermost:
3250 (save-excursion (save-restriction ...))
3252 usage: (save-restriction &rest BODY) */)
3256 register Lisp_Object val
;
3257 int count
= SPECPDL_INDEX ();
3259 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3260 val
= Fprogn (body
);
3261 return unbind_to (count
, val
);
3264 /* Buffer for the most recent text displayed by Fmessage_box. */
3265 static char *message_text
;
3267 /* Allocated length of that buffer. */
3268 static int message_length
;
3270 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3271 doc
: /* Print a one-line message at the bottom of the screen.
3272 The message also goes into the `*Messages*' buffer.
3273 \(In keyboard macros, that's all it does.)
3275 The first argument is a format control string, and the rest are data
3276 to be formatted under control of the string. See `format' for details.
3278 If the first argument is nil or the empty string, the function clears
3279 any existing message; this lets the minibuffer contents show. See
3280 also `current-message'.
3282 usage: (message FORMAT-STRING &rest ARGS) */)
3288 || (STRINGP (args
[0])
3289 && SBYTES (args
[0]) == 0))
3296 register Lisp_Object val
;
3297 val
= Fformat (nargs
, args
);
3298 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3303 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3304 doc
: /* Display a message, in a dialog box if possible.
3305 If a dialog box is not available, use the echo area.
3306 The first argument is a format control string, and the rest are data
3307 to be formatted under control of the string. See `format' for details.
3309 If the first argument is nil or the empty string, clear any existing
3310 message; let the minibuffer contents show.
3312 usage: (message-box FORMAT-STRING &rest ARGS) */)
3324 register Lisp_Object val
;
3325 val
= Fformat (nargs
, args
);
3327 /* The MS-DOS frames support popup menus even though they are
3328 not FRAME_WINDOW_P. */
3329 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3330 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3332 Lisp_Object pane
, menu
, obj
;
3333 struct gcpro gcpro1
;
3334 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3336 menu
= Fcons (val
, pane
);
3337 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3341 #endif /* HAVE_MENUS */
3342 /* Copy the data so that it won't move when we GC. */
3345 message_text
= (char *)xmalloc (80);
3346 message_length
= 80;
3348 if (SBYTES (val
) > message_length
)
3350 message_length
= SBYTES (val
);
3351 message_text
= (char *)xrealloc (message_text
, message_length
);
3353 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3354 message2 (message_text
, SBYTES (val
),
3355 STRING_MULTIBYTE (val
));
3360 extern Lisp_Object last_nonmenu_event
;
3363 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3364 doc
: /* Display a message in a dialog box or in the echo area.
3365 If this command was invoked with the mouse, use a dialog box if
3366 `use-dialog-box' is non-nil.
3367 Otherwise, use the echo area.
3368 The first argument is a format control string, and the rest are data
3369 to be formatted under control of the string. See `format' for details.
3371 If the first argument is nil or the empty string, clear any existing
3372 message; let the minibuffer contents show.
3374 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3380 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3382 return Fmessage_box (nargs
, args
);
3384 return Fmessage (nargs
, args
);
3387 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3388 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3391 return current_message ();
3395 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3396 doc
: /* Return a copy of STRING with text properties added.
3397 First argument is the string to copy.
3398 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3399 properties to add to the result.
3400 usage: (propertize STRING &rest PROPERTIES) */)
3405 Lisp_Object properties
, string
;
3406 struct gcpro gcpro1
, gcpro2
;
3409 /* Number of args must be odd. */
3410 if ((nargs
& 1) == 0 || nargs
< 1)
3411 error ("Wrong number of arguments");
3413 properties
= string
= Qnil
;
3414 GCPRO2 (properties
, string
);
3416 /* First argument must be a string. */
3417 CHECK_STRING (args
[0]);
3418 string
= Fcopy_sequence (args
[0]);
3420 for (i
= 1; i
< nargs
; i
+= 2)
3421 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3423 Fadd_text_properties (make_number (0),
3424 make_number (SCHARS (string
)),
3425 properties
, string
);
3426 RETURN_UNGCPRO (string
);
3430 /* Number of bytes that STRING will occupy when put into the result.
3431 MULTIBYTE is nonzero if the result should be multibyte. */
3433 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3434 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3435 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3438 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3439 doc
: /* Format a string out of a format-string and arguments.
3440 The first argument is a format control string.
3441 The other arguments are substituted into it to make the result, a string.
3442 It may contain %-sequences meaning to substitute the next argument.
3443 %s means print a string argument. Actually, prints any object, with `princ'.
3444 %d means print as number in decimal (%o octal, %x hex).
3445 %X is like %x, but uses upper case.
3446 %e means print a number in exponential notation.
3447 %f means print a number in decimal-point notation.
3448 %g means print a number in exponential notation
3449 or decimal-point notation, whichever uses fewer characters.
3450 %c means print a number as a single character.
3451 %S means print any object as an s-expression (using `prin1').
3452 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3453 Use %% to put a single % into the output.
3455 The basic structure of a %-sequence is
3456 % <flags> <width> <precision> character
3457 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3459 usage: (format STRING &rest OBJECTS) */)
3462 register Lisp_Object
*args
;
3464 register int n
; /* The number of the next arg to substitute */
3465 register int total
; /* An estimate of the final length */
3467 register unsigned char *format
, *end
, *format_start
;
3469 /* Nonzero if the output should be a multibyte string,
3470 which is true if any of the inputs is one. */
3472 /* When we make a multibyte string, we must pay attention to the
3473 byte combining problem, i.e., a byte may be combined with a
3474 multibyte charcter of the previous string. This flag tells if we
3475 must consider such a situation or not. */
3476 int maybe_combine_byte
;
3477 unsigned char *this_format
;
3478 /* Precision for each spec, or -1, a flag value meaning no precision
3479 was given in that spec. Element 0, corresonding to the format
3480 string itself, will not be used. Element NARGS, corresponding to
3481 no argument, *will* be assigned to in the case that a `%' and `.'
3482 occur after the final format specifier. */
3483 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3486 int arg_intervals
= 0;
3489 /* discarded[I] is 1 if byte I of the format
3490 string was not copied into the output.
3491 It is 2 if byte I was not the first byte of its character. */
3492 char *discarded
= 0;
3494 /* Each element records, for one argument,
3495 the start and end bytepos in the output string,
3496 and whether the argument is a string with intervals.
3497 info[0] is unused. Unused elements have -1 for start. */
3500 int start
, end
, intervals
;
3503 /* It should not be necessary to GCPRO ARGS, because
3504 the caller in the interpreter should take care of that. */
3506 /* Try to determine whether the result should be multibyte.
3507 This is not always right; sometimes the result needs to be multibyte
3508 because of an object that we will pass through prin1,
3509 and in that case, we won't know it here. */
3510 for (n
= 0; n
< nargs
; n
++)
3512 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3514 /* Piggyback on this loop to initialize precision[N]. */
3517 precision
[nargs
] = -1;
3519 CHECK_STRING (args
[0]);
3520 /* We may have to change "%S" to "%s". */
3521 args
[0] = Fcopy_sequence (args
[0]);
3523 /* GC should never happen here, so abort if it does. */
3526 /* If we start out planning a unibyte result,
3527 then discover it has to be multibyte, we jump back to retry.
3528 That can only happen from the first large while loop below. */
3531 format
= SDATA (args
[0]);
3532 format_start
= format
;
3533 end
= format
+ SBYTES (args
[0]);
3536 /* Make room in result for all the non-%-codes in the control string. */
3537 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3539 /* Allocate the info and discarded tables. */
3541 int nbytes
= (nargs
+1) * sizeof *info
;
3544 info
= (struct info
*) alloca (nbytes
);
3545 bzero (info
, nbytes
);
3546 for (i
= 0; i
<= nargs
; i
++)
3549 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3550 bzero (discarded
, SBYTES (args
[0]));
3553 /* Add to TOTAL enough space to hold the converted arguments. */
3556 while (format
!= end
)
3557 if (*format
++ == '%')
3560 int actual_width
= 0;
3561 unsigned char *this_format_start
= format
- 1;
3562 int field_width
= 0;
3564 /* General format specifications look like
3566 '%' [flags] [field-width] [precision] format
3571 field-width ::= [0-9]+
3572 precision ::= '.' [0-9]*
3574 If a field-width is specified, it specifies to which width
3575 the output should be padded with blanks, iff the output
3576 string is shorter than field-width.
3578 If precision is specified, it specifies the number of
3579 digits to print after the '.' for floats, or the max.
3580 number of chars to print from a string. */
3582 while (format
!= end
3583 && (*format
== '-' || *format
== '0' || *format
== '#'
3584 || * format
== ' '))
3587 if (*format
>= '0' && *format
<= '9')
3589 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3590 field_width
= 10 * field_width
+ *format
- '0';
3593 /* N is not incremented for another few lines below, so refer to
3594 element N+1 (which might be precision[NARGS]). */
3598 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3599 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3602 if (format
- this_format_start
+ 1 > longest_format
)
3603 longest_format
= format
- this_format_start
+ 1;
3606 error ("Format string ends in middle of format specifier");
3609 else if (++n
>= nargs
)
3610 error ("Not enough arguments for format string");
3611 else if (*format
== 'S')
3613 /* For `S', prin1 the argument and then treat like a string. */
3614 register Lisp_Object tem
;
3615 tem
= Fprin1_to_string (args
[n
], Qnil
);
3616 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3622 /* If we restart the loop, we should not come here again
3623 because args[n] is now a string and calling
3624 Fprin1_to_string on it produces superflous double
3625 quotes. So, change "%S" to "%s" now. */
3629 else if (SYMBOLP (args
[n
]))
3631 args
[n
] = SYMBOL_NAME (args
[n
]);
3632 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3639 else if (STRINGP (args
[n
]))
3642 if (*format
!= 's' && *format
!= 'S')
3643 error ("Format specifier doesn't match argument type");
3644 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3645 to be as large as is calculated here. Easy check for
3646 the case PRECISION = 0. */
3647 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3648 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3650 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3651 else if (INTEGERP (args
[n
]) && *format
!= 's')
3653 /* The following loop assumes the Lisp type indicates
3654 the proper way to pass the argument.
3655 So make sure we have a flonum if the argument should
3657 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3658 args
[n
] = Ffloat (args
[n
]);
3660 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3661 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3662 error ("Invalid format operation %%%c", *format
);
3667 if (! ASCII_CHAR_P (XINT (args
[n
]))
3668 /* Note: No one can remeber why we have to treat
3669 the character 0 as a multibyte character here.
3670 But, until it causes a real problem, let's
3672 || XINT (args
[n
]) == 0)
3679 args
[n
] = Fchar_to_string (args
[n
]);
3680 thissize
= SBYTES (args
[n
]);
3682 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3685 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3686 thissize
= SBYTES (args
[n
]);
3690 else if (FLOATP (args
[n
]) && *format
!= 's')
3692 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3694 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3695 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3696 error ("Invalid format operation %%%c", *format
);
3697 args
[n
] = Ftruncate (args
[n
], Qnil
);
3700 /* Note that we're using sprintf to print floats,
3701 so we have to take into account what that function
3703 /* Filter out flag value of -1. */
3704 thissize
= (MAX_10_EXP
+ 100
3705 + (precision
[n
] > 0 ? precision
[n
] : 0));
3709 /* Anything but a string, convert to a string using princ. */
3710 register Lisp_Object tem
;
3711 tem
= Fprin1_to_string (args
[n
], Qt
);
3712 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3721 thissize
+= max (0, field_width
- actual_width
);
3722 total
+= thissize
+ 4;
3727 /* Now we can no longer jump to retry.
3728 TOTAL and LONGEST_FORMAT are known for certain. */
3730 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3732 /* Allocate the space for the result.
3733 Note that TOTAL is an overestimate. */
3734 SAFE_ALLOCA (buf
, char *, total
);
3740 /* Scan the format and store result in BUF. */
3741 format
= SDATA (args
[0]);
3742 format_start
= format
;
3743 end
= format
+ SBYTES (args
[0]);
3744 maybe_combine_byte
= 0;
3745 while (format
!= end
)
3751 unsigned char *this_format_start
= format
;
3753 discarded
[format
- format_start
] = 1;
3756 while (index("-0# ", *format
))
3762 discarded
[format
- format_start
] = 1;
3766 minlen
= atoi (format
);
3768 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3770 discarded
[format
- format_start
] = 1;
3774 if (*format
++ == '%')
3783 discarded
[format
- format_start
- 1] = 1;
3784 info
[n
].start
= nchars
;
3786 if (STRINGP (args
[n
]))
3788 /* handle case (precision[n] >= 0) */
3791 int nbytes
, start
, end
;
3794 /* lisp_string_width ignores a precision of 0, but GNU
3795 libc functions print 0 characters when the precision
3796 is 0. Imitate libc behavior here. Changing
3797 lisp_string_width is the right thing, and will be
3798 done, but meanwhile we work with it. */
3800 if (precision
[n
] == 0)
3801 width
= nchars_string
= nbytes
= 0;
3802 else if (precision
[n
] > 0)
3803 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3805 { /* no precision spec given for this argument */
3806 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3807 nbytes
= SBYTES (args
[n
]);
3808 nchars_string
= SCHARS (args
[n
]);
3811 /* If spec requires it, pad on right with spaces. */
3812 padding
= minlen
- width
;
3814 while (padding
-- > 0)
3820 info
[n
].start
= start
= nchars
;
3821 nchars
+= nchars_string
;
3826 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3827 && STRING_MULTIBYTE (args
[n
])
3828 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3829 maybe_combine_byte
= 1;
3831 p
+= copy_text (SDATA (args
[n
]), p
,
3833 STRING_MULTIBYTE (args
[n
]), multibyte
);
3835 info
[n
].end
= nchars
;
3838 while (padding
-- > 0)
3844 /* If this argument has text properties, record where
3845 in the result string it appears. */
3846 if (STRING_INTERVALS (args
[n
]))
3847 info
[n
].intervals
= arg_intervals
= 1;
3849 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3853 bcopy (this_format_start
, this_format
,
3854 format
- this_format_start
);
3855 this_format
[format
- this_format_start
] = 0;
3857 if (INTEGERP (args
[n
]))
3858 sprintf (p
, this_format
, XINT (args
[n
]));
3860 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3864 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3865 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3866 maybe_combine_byte
= 1;
3867 this_nchars
= strlen (p
);
3869 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3872 nchars
+= this_nchars
;
3873 info
[n
].end
= nchars
;
3877 else if (STRING_MULTIBYTE (args
[0]))
3879 /* Copy a whole multibyte character. */
3882 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3883 && !CHAR_HEAD_P (*format
))
3884 maybe_combine_byte
= 1;
3886 while (! CHAR_HEAD_P (*format
))
3888 discarded
[format
- format_start
] = 2;
3895 /* Convert a single-byte character to multibyte. */
3896 int len
= copy_text (format
, p
, 1, 0, 1);
3903 *p
++ = *format
++, nchars
++;
3906 if (p
> buf
+ total
)
3909 if (maybe_combine_byte
)
3910 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3911 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3913 /* If we allocated BUF with malloc, free it too. */
3916 /* If the format string has text properties, or any of the string
3917 arguments has text properties, set up text properties of the
3920 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3922 Lisp_Object len
, new_len
, props
;
3923 struct gcpro gcpro1
;
3925 /* Add text properties from the format string. */
3926 len
= make_number (SCHARS (args
[0]));
3927 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3932 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3935 /* Adjust the bounds of each text property
3936 to the proper start and end in the output string. */
3938 /* Put the positions in PROPS in increasing order, so that
3939 we can do (effectively) one scan through the position
3940 space of the format string. */
3941 props
= Fnreverse (props
);
3943 /* BYTEPOS is the byte position in the format string,
3944 POSITION is the untranslated char position in it,
3945 TRANSLATED is the translated char position in BUF,
3946 and ARGN is the number of the next arg we will come to. */
3947 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3954 /* First adjust the property start position. */
3955 pos
= XINT (XCAR (item
));
3957 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3958 up to this position. */
3959 for (; position
< pos
; bytepos
++)
3961 if (! discarded
[bytepos
])
3962 position
++, translated
++;
3963 else if (discarded
[bytepos
] == 1)
3966 if (translated
== info
[argn
].start
)
3968 translated
+= info
[argn
].end
- info
[argn
].start
;
3974 XSETCAR (item
, make_number (translated
));
3976 /* Likewise adjust the property end position. */
3977 pos
= XINT (XCAR (XCDR (item
)));
3979 for (; bytepos
< pos
; bytepos
++)
3981 if (! discarded
[bytepos
])
3982 position
++, translated
++;
3983 else if (discarded
[bytepos
] == 1)
3986 if (translated
== info
[argn
].start
)
3988 translated
+= info
[argn
].end
- info
[argn
].start
;
3994 XSETCAR (XCDR (item
), make_number (translated
));
3997 add_text_properties_from_list (val
, props
, make_number (0));
4000 /* Add text properties from arguments. */
4002 for (n
= 1; n
< nargs
; ++n
)
4003 if (info
[n
].intervals
)
4005 len
= make_number (SCHARS (args
[n
]));
4006 new_len
= make_number (info
[n
].end
- info
[n
].start
);
4007 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
4008 extend_property_ranges (props
, len
, new_len
);
4009 /* If successive arguments have properites, be sure that
4010 the value of `composition' property be the copy. */
4011 if (n
> 1 && info
[n
- 1].end
)
4012 make_composition_value_copy (props
);
4013 add_text_properties_from_list (val
, props
,
4014 make_number (info
[n
].start
));
4024 format2 (string1
, arg0
, arg1
)
4026 Lisp_Object arg0
, arg1
;
4028 Lisp_Object args
[3];
4029 args
[0] = build_string (string1
);
4032 return Fformat (3, args
);
4035 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4036 doc
: /* Return t if two characters match, optionally ignoring case.
4037 Both arguments must be characters (i.e. integers).
4038 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4040 register Lisp_Object c1
, c2
;
4046 if (XINT (c1
) == XINT (c2
))
4048 if (NILP (current_buffer
->case_fold_search
))
4051 /* Do these in separate statements,
4052 then compare the variables.
4053 because of the way DOWNCASE uses temp variables. */
4055 if (NILP (current_buffer
->enable_multibyte_characters
)
4056 && ! ASCII_CHAR_P (i1
))
4058 MAKE_CHAR_MULTIBYTE (i1
);
4061 if (NILP (current_buffer
->enable_multibyte_characters
)
4062 && ! ASCII_CHAR_P (i2
))
4064 MAKE_CHAR_MULTIBYTE (i2
);
4068 return (i1
== i2
? Qt
: Qnil
);
4071 /* Transpose the markers in two regions of the current buffer, and
4072 adjust the ones between them if necessary (i.e.: if the regions
4075 START1, END1 are the character positions of the first region.
4076 START1_BYTE, END1_BYTE are the byte positions.
4077 START2, END2 are the character positions of the second region.
4078 START2_BYTE, END2_BYTE are the byte positions.
4080 Traverses the entire marker list of the buffer to do so, adding an
4081 appropriate amount to some, subtracting from some, and leaving the
4082 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4084 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4087 transpose_markers (start1
, end1
, start2
, end2
,
4088 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
4089 register int start1
, end1
, start2
, end2
;
4090 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
4092 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4093 register struct Lisp_Marker
*marker
;
4095 /* Update point as if it were a marker. */
4099 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4100 PT_BYTE
+ (end2_byte
- end1_byte
));
4101 else if (PT
< start2
)
4102 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4103 (PT_BYTE
+ (end2_byte
- start2_byte
)
4104 - (end1_byte
- start1_byte
)));
4106 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4107 PT_BYTE
- (start2_byte
- start1_byte
));
4109 /* We used to adjust the endpoints here to account for the gap, but that
4110 isn't good enough. Even if we assume the caller has tried to move the
4111 gap out of our way, it might still be at start1 exactly, for example;
4112 and that places it `inside' the interval, for our purposes. The amount
4113 of adjustment is nontrivial if there's a `denormalized' marker whose
4114 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4115 the dirty work to Fmarker_position, below. */
4117 /* The difference between the region's lengths */
4118 diff
= (end2
- start2
) - (end1
- start1
);
4119 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4121 /* For shifting each marker in a region by the length of the other
4122 region plus the distance between the regions. */
4123 amt1
= (end2
- start2
) + (start2
- end1
);
4124 amt2
= (end1
- start1
) + (start2
- end1
);
4125 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4126 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4128 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4130 mpos
= marker
->bytepos
;
4131 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4133 if (mpos
< end1_byte
)
4135 else if (mpos
< start2_byte
)
4139 marker
->bytepos
= mpos
;
4141 mpos
= marker
->charpos
;
4142 if (mpos
>= start1
&& mpos
< end2
)
4146 else if (mpos
< start2
)
4151 marker
->charpos
= mpos
;
4155 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4156 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4157 The regions may not be overlapping, because the size of the buffer is
4158 never changed in a transposition.
4160 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4161 any markers that happen to be located in the regions.
4163 Transposing beyond buffer boundaries is an error. */)
4164 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4165 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4167 register int start1
, end1
, start2
, end2
;
4168 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4169 int gap
, len1
, len_mid
, len2
;
4170 unsigned char *start1_addr
, *start2_addr
, *temp
;
4172 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4173 cur_intv
= BUF_INTERVALS (current_buffer
);
4175 validate_region (&startr1
, &endr1
);
4176 validate_region (&startr2
, &endr2
);
4178 start1
= XFASTINT (startr1
);
4179 end1
= XFASTINT (endr1
);
4180 start2
= XFASTINT (startr2
);
4181 end2
= XFASTINT (endr2
);
4184 /* Swap the regions if they're reversed. */
4187 register int glumph
= start1
;
4195 len1
= end1
- start1
;
4196 len2
= end2
- start2
;
4199 error ("Transposed regions overlap");
4200 else if (start1
== end1
|| start2
== end2
)
4201 error ("Transposed region has length 0");
4203 /* The possibilities are:
4204 1. Adjacent (contiguous) regions, or separate but equal regions
4205 (no, really equal, in this case!), or
4206 2. Separate regions of unequal size.
4208 The worst case is usually No. 2. It means that (aside from
4209 potential need for getting the gap out of the way), there also
4210 needs to be a shifting of the text between the two regions. So
4211 if they are spread far apart, we are that much slower... sigh. */
4213 /* It must be pointed out that the really studly thing to do would
4214 be not to move the gap at all, but to leave it in place and work
4215 around it if necessary. This would be extremely efficient,
4216 especially considering that people are likely to do
4217 transpositions near where they are working interactively, which
4218 is exactly where the gap would be found. However, such code
4219 would be much harder to write and to read. So, if you are
4220 reading this comment and are feeling squirrely, by all means have
4221 a go! I just didn't feel like doing it, so I will simply move
4222 the gap the minimum distance to get it out of the way, and then
4223 deal with an unbroken array. */
4225 /* Make sure the gap won't interfere, by moving it out of the text
4226 we will operate on. */
4227 if (start1
< gap
&& gap
< end2
)
4229 if (gap
- start1
< end2
- gap
)
4235 start1_byte
= CHAR_TO_BYTE (start1
);
4236 start2_byte
= CHAR_TO_BYTE (start2
);
4237 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4238 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4240 #ifdef BYTE_COMBINING_DEBUG
4243 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4244 len2_byte
, start1
, start1_byte
)
4245 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4246 len1_byte
, end2
, start2_byte
+ len2_byte
)
4247 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4248 len1_byte
, end2
, start2_byte
+ len2_byte
))
4253 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4254 len2_byte
, start1
, start1_byte
)
4255 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4256 len1_byte
, start2
, start2_byte
)
4257 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4258 len2_byte
, end1
, start1_byte
+ len1_byte
)
4259 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4260 len1_byte
, end2
, start2_byte
+ len2_byte
))
4265 /* Hmmm... how about checking to see if the gap is large
4266 enough to use as the temporary storage? That would avoid an
4267 allocation... interesting. Later, don't fool with it now. */
4269 /* Working without memmove, for portability (sigh), so must be
4270 careful of overlapping subsections of the array... */
4272 if (end1
== start2
) /* adjacent regions */
4274 modify_region (current_buffer
, start1
, end2
);
4275 record_change (start1
, len1
+ len2
);
4277 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4278 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4279 Fset_text_properties (make_number (start1
), make_number (end2
),
4282 /* First region smaller than second. */
4283 if (len1_byte
< len2_byte
)
4287 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4289 /* Don't precompute these addresses. We have to compute them
4290 at the last minute, because the relocating allocator might
4291 have moved the buffer around during the xmalloc. */
4292 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4293 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4295 bcopy (start2_addr
, temp
, len2_byte
);
4296 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4297 bcopy (temp
, start1_addr
, len2_byte
);
4301 /* First region not smaller than second. */
4305 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4306 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4307 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4308 bcopy (start1_addr
, temp
, len1_byte
);
4309 bcopy (start2_addr
, start1_addr
, len2_byte
);
4310 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4313 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4314 len1
, current_buffer
, 0);
4315 graft_intervals_into_buffer (tmp_interval2
, start1
,
4316 len2
, current_buffer
, 0);
4317 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4318 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4320 /* Non-adjacent regions, because end1 != start2, bleagh... */
4323 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4325 if (len1_byte
== len2_byte
)
4326 /* Regions are same size, though, how nice. */
4330 modify_region (current_buffer
, start1
, end1
);
4331 modify_region (current_buffer
, start2
, end2
);
4332 record_change (start1
, len1
);
4333 record_change (start2
, len2
);
4334 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4335 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4336 Fset_text_properties (make_number (start1
), make_number (end1
),
4338 Fset_text_properties (make_number (start2
), make_number (end2
),
4341 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4342 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4343 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4344 bcopy (start1_addr
, temp
, len1_byte
);
4345 bcopy (start2_addr
, start1_addr
, len2_byte
);
4346 bcopy (temp
, start2_addr
, len1_byte
);
4349 graft_intervals_into_buffer (tmp_interval1
, start2
,
4350 len1
, current_buffer
, 0);
4351 graft_intervals_into_buffer (tmp_interval2
, start1
,
4352 len2
, current_buffer
, 0);
4355 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4356 /* Non-adjacent & unequal size, area between must also be shifted. */
4360 modify_region (current_buffer
, start1
, end2
);
4361 record_change (start1
, (end2
- start1
));
4362 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4363 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4364 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4365 Fset_text_properties (make_number (start1
), make_number (end2
),
4368 /* holds region 2 */
4369 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4370 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4371 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4372 bcopy (start2_addr
, temp
, len2_byte
);
4373 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4374 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4375 bcopy (temp
, start1_addr
, len2_byte
);
4378 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4379 len1
, current_buffer
, 0);
4380 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4381 len_mid
, current_buffer
, 0);
4382 graft_intervals_into_buffer (tmp_interval2
, start1
,
4383 len2
, current_buffer
, 0);
4386 /* Second region smaller than first. */
4390 record_change (start1
, (end2
- start1
));
4391 modify_region (current_buffer
, start1
, end2
);
4393 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4394 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4395 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4396 Fset_text_properties (make_number (start1
), make_number (end2
),
4399 /* holds region 1 */
4400 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4401 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4402 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4403 bcopy (start1_addr
, temp
, len1_byte
);
4404 bcopy (start2_addr
, start1_addr
, len2_byte
);
4405 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4406 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4409 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4410 len1
, current_buffer
, 0);
4411 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4412 len_mid
, current_buffer
, 0);
4413 graft_intervals_into_buffer (tmp_interval2
, start1
,
4414 len2
, current_buffer
, 0);
4417 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4418 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4421 /* When doing multiple transpositions, it might be nice
4422 to optimize this. Perhaps the markers in any one buffer
4423 should be organized in some sorted data tree. */
4424 if (NILP (leave_markers
))
4426 transpose_markers (start1
, end1
, start2
, end2
,
4427 start1_byte
, start1_byte
+ len1_byte
,
4428 start2_byte
, start2_byte
+ len2_byte
);
4429 fix_start_end_in_overlays (start1
, end2
);
4441 Qbuffer_access_fontify_functions
4442 = intern ("buffer-access-fontify-functions");
4443 staticpro (&Qbuffer_access_fontify_functions
);
4445 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4446 doc
: /* Non-nil means text motion commands don't notice fields. */);
4447 Vinhibit_field_text_motion
= Qnil
;
4449 DEFVAR_LISP ("buffer-access-fontify-functions",
4450 &Vbuffer_access_fontify_functions
,
4451 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4452 Each function is called with two arguments which specify the range
4453 of the buffer being accessed. */);
4454 Vbuffer_access_fontify_functions
= Qnil
;
4458 extern Lisp_Object Vprin1_to_string_buffer
;
4459 obuf
= Fcurrent_buffer ();
4460 /* Do this here, because init_buffer_once is too early--it won't work. */
4461 Fset_buffer (Vprin1_to_string_buffer
);
4462 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4463 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4468 DEFVAR_LISP ("buffer-access-fontified-property",
4469 &Vbuffer_access_fontified_property
,
4470 doc
: /* Property which (if non-nil) indicates text has been fontified.
4471 `buffer-substring' need not call the `buffer-access-fontify-functions'
4472 functions if all the text being accessed has this property. */);
4473 Vbuffer_access_fontified_property
= Qnil
;
4475 DEFVAR_LISP ("system-name", &Vsystem_name
,
4476 doc
: /* The name of the machine Emacs is running on. */);
4478 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4479 doc
: /* The full name of the user logged in. */);
4481 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4482 doc
: /* The user's name, taken from environment variables if possible. */);
4484 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4485 doc
: /* The user's name, based upon the real uid only. */);
4487 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4488 doc
: /* The release of the operating system Emacs is running on. */);
4490 defsubr (&Spropertize
);
4491 defsubr (&Schar_equal
);
4492 defsubr (&Sgoto_char
);
4493 defsubr (&Sstring_to_char
);
4494 defsubr (&Schar_to_string
);
4495 defsubr (&Sbuffer_substring
);
4496 defsubr (&Sbuffer_substring_no_properties
);
4497 defsubr (&Sbuffer_string
);
4499 defsubr (&Spoint_marker
);
4500 defsubr (&Smark_marker
);
4502 defsubr (&Sregion_beginning
);
4503 defsubr (&Sregion_end
);
4505 staticpro (&Qfield
);
4506 Qfield
= intern ("field");
4507 staticpro (&Qboundary
);
4508 Qboundary
= intern ("boundary");
4509 defsubr (&Sfield_beginning
);
4510 defsubr (&Sfield_end
);
4511 defsubr (&Sfield_string
);
4512 defsubr (&Sfield_string_no_properties
);
4513 defsubr (&Sdelete_field
);
4514 defsubr (&Sconstrain_to_field
);
4516 defsubr (&Sline_beginning_position
);
4517 defsubr (&Sline_end_position
);
4519 /* defsubr (&Smark); */
4520 /* defsubr (&Sset_mark); */
4521 defsubr (&Ssave_excursion
);
4522 defsubr (&Ssave_current_buffer
);
4524 defsubr (&Sbufsize
);
4525 defsubr (&Spoint_max
);
4526 defsubr (&Spoint_min
);
4527 defsubr (&Spoint_min_marker
);
4528 defsubr (&Spoint_max_marker
);
4529 defsubr (&Sgap_position
);
4530 defsubr (&Sgap_size
);
4531 defsubr (&Sposition_bytes
);
4532 defsubr (&Sbyte_to_position
);
4538 defsubr (&Sfollowing_char
);
4539 defsubr (&Sprevious_char
);
4540 defsubr (&Schar_after
);
4541 defsubr (&Schar_before
);
4543 defsubr (&Sinsert_before_markers
);
4544 defsubr (&Sinsert_and_inherit
);
4545 defsubr (&Sinsert_and_inherit_before_markers
);
4546 defsubr (&Sinsert_char
);
4547 defsubr (&Sinsert_byte
);
4549 defsubr (&Suser_login_name
);
4550 defsubr (&Suser_real_login_name
);
4551 defsubr (&Suser_uid
);
4552 defsubr (&Suser_real_uid
);
4553 defsubr (&Suser_full_name
);
4554 defsubr (&Semacs_pid
);
4555 defsubr (&Scurrent_time
);
4556 defsubr (&Sget_internal_run_time
);
4557 defsubr (&Sformat_time_string
);
4558 defsubr (&Sfloat_time
);
4559 defsubr (&Sdecode_time
);
4560 defsubr (&Sencode_time
);
4561 defsubr (&Scurrent_time_string
);
4562 defsubr (&Scurrent_time_zone
);
4563 defsubr (&Sset_time_zone_rule
);
4564 defsubr (&Ssystem_name
);
4565 defsubr (&Smessage
);
4566 defsubr (&Smessage_box
);
4567 defsubr (&Smessage_or_box
);
4568 defsubr (&Scurrent_message
);
4571 defsubr (&Sinsert_buffer_substring
);
4572 defsubr (&Scompare_buffer_substrings
);
4573 defsubr (&Ssubst_char_in_region
);
4574 defsubr (&Stranslate_region_internal
);
4575 defsubr (&Sdelete_region
);
4576 defsubr (&Sdelete_and_extract_region
);
4578 defsubr (&Snarrow_to_region
);
4579 defsubr (&Ssave_restriction
);
4580 defsubr (&Stranspose_regions
);
4583 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4584 (do not change this comment) */