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 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>
40 /* systime.h includes <sys/time.h> which, on some systems, is required
41 for <sys/resource.h>; thus systime.h must be included before
45 #if defined HAVE_SYS_RESOURCE_H
46 #include <sys/resource.h>
52 #include "intervals.h"
54 #include "character.h"
61 #define MAX_10_EXP DBL_MAX_10_EXP
63 #define MAX_10_EXP 310
71 extern char **environ
;
74 extern Lisp_Object make_time
P_ ((time_t));
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),
529 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
530 and POS is at beginning of a field, which can also be interpreted
531 as the end of the previous field. Note that the case where if
532 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
533 more natural one; then we avoid treating the beginning of a field
535 if (NILP (merge_at_boundary
))
537 Lisp_Object field
= get_pos_property (pos
, Qfield
, Qnil
);
538 if (!EQ (field
, after_field
))
540 if (!EQ (field
, before_field
))
542 if (NILP (field
) && at_field_start
&& at_field_end
)
543 /* If an inserted char would have a nil field while the surrounding
544 text is non-nil, we're probably not looking at a
545 zero-length field, but instead at a non-nil field that's
546 not intended for editing (such as comint's prompts). */
547 at_field_end
= at_field_start
= 0;
550 /* Note about special `boundary' fields:
552 Consider the case where the point (`.') is between the fields `x' and `y':
556 In this situation, if merge_at_boundary is true, we consider the
557 `x' and `y' fields as forming one big merged field, and so the end
558 of the field is the end of `y'.
560 However, if `x' and `y' are separated by a special `boundary' field
561 (a field with a `field' char-property of 'boundary), then we ignore
562 this special field when merging adjacent fields. Here's the same
563 situation, but with a `boundary' field between the `x' and `y' fields:
567 Here, if point is at the end of `x', the beginning of `y', or
568 anywhere in-between (within the `boundary' field), we merge all
569 three fields and consider the beginning as being the beginning of
570 the `x' field, and the end as being the end of the `y' field. */
575 /* POS is at the edge of a field, and we should consider it as
576 the beginning of the following field. */
577 *beg
= XFASTINT (pos
);
579 /* Find the previous field boundary. */
582 if (!NILP (merge_at_boundary
) && EQ (before_field
, Qboundary
))
583 /* Skip a `boundary' field. */
584 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
587 p
= Fprevious_single_char_property_change (p
, Qfield
, Qnil
,
589 *beg
= NILP (p
) ? BEGV
: XFASTINT (p
);
596 /* POS is at the edge of a field, and we should consider it as
597 the end of the previous field. */
598 *end
= XFASTINT (pos
);
600 /* Find the next field boundary. */
602 if (!NILP (merge_at_boundary
) && EQ (after_field
, Qboundary
))
603 /* Skip a `boundary' field. */
604 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
607 pos
= Fnext_single_char_property_change (pos
, Qfield
, Qnil
,
609 *end
= NILP (pos
) ? ZV
: XFASTINT (pos
);
615 DEFUN ("delete-field", Fdelete_field
, Sdelete_field
, 0, 1, 0,
616 doc
: /* Delete the field surrounding POS.
617 A field is a region of text with the same `field' property.
618 If POS is nil, the value of point is used for POS. */)
623 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
625 del_range (beg
, end
);
629 DEFUN ("field-string", Ffield_string
, Sfield_string
, 0, 1, 0,
630 doc
: /* Return the contents of the field surrounding POS as a string.
631 A field is a region of text with the same `field' property.
632 If POS is nil, the value of point is used for POS. */)
637 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
638 return make_buffer_string (beg
, end
, 1);
641 DEFUN ("field-string-no-properties", Ffield_string_no_properties
, Sfield_string_no_properties
, 0, 1, 0,
642 doc
: /* Return the contents of the field around POS, without text-properties.
643 A field is a region of text with the same `field' property.
644 If POS is nil, the value of point is used for POS. */)
649 find_field (pos
, Qnil
, Qnil
, &beg
, Qnil
, &end
);
650 return make_buffer_string (beg
, end
, 0);
653 DEFUN ("field-beginning", Ffield_beginning
, Sfield_beginning
, 0, 3, 0,
654 doc
: /* Return the beginning of the field surrounding POS.
655 A field is a region of text with the same `field' property.
656 If POS is nil, the value of point is used for POS.
657 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
658 field, then the beginning of the *previous* field is returned.
659 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
660 is before LIMIT, then LIMIT will be returned instead. */)
661 (pos
, escape_from_edge
, limit
)
662 Lisp_Object pos
, escape_from_edge
, limit
;
665 find_field (pos
, escape_from_edge
, limit
, &beg
, Qnil
, 0);
666 return make_number (beg
);
669 DEFUN ("field-end", Ffield_end
, Sfield_end
, 0, 3, 0,
670 doc
: /* Return the end of the field surrounding POS.
671 A field is a region of text with the same `field' property.
672 If POS is nil, the value of point is used for POS.
673 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
674 then the end of the *following* field is returned.
675 If LIMIT is non-nil, it is a buffer position; if the end of the field
676 is after LIMIT, then LIMIT will be returned instead. */)
677 (pos
, escape_from_edge
, limit
)
678 Lisp_Object pos
, escape_from_edge
, limit
;
681 find_field (pos
, escape_from_edge
, Qnil
, 0, limit
, &end
);
682 return make_number (end
);
685 DEFUN ("constrain-to-field", Fconstrain_to_field
, Sconstrain_to_field
, 2, 5, 0,
686 doc
: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
688 A field is a region of text with the same `field' property.
689 If NEW-POS is nil, then the current point is used instead, and set to the
690 constrained position if that is different.
692 If OLD-POS is at the boundary of two fields, then the allowable
693 positions for NEW-POS depends on the value of the optional argument
694 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
695 constrained to the field that has the same `field' char-property
696 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
697 is non-nil, NEW-POS is constrained to the union of the two adjacent
698 fields. Additionally, if two fields are separated by another field with
699 the special value `boundary', then any point within this special field is
700 also considered to be `on the boundary'.
702 If the optional argument ONLY-IN-LINE is non-nil and constraining
703 NEW-POS would move it to a different line, NEW-POS is returned
704 unconstrained. This useful for commands that move by line, like
705 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
706 only in the case where they can still move to the right line.
708 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
709 a non-nil property of that name, then any field boundaries are ignored.
711 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
712 (new_pos
, old_pos
, escape_from_edge
, only_in_line
, inhibit_capture_property
)
713 Lisp_Object new_pos
, old_pos
;
714 Lisp_Object escape_from_edge
, only_in_line
, inhibit_capture_property
;
716 /* If non-zero, then the original point, before re-positioning. */
720 /* Use the current point, and afterwards, set it. */
723 XSETFASTINT (new_pos
, PT
);
726 if (NILP (Vinhibit_field_text_motion
)
727 && !EQ (new_pos
, old_pos
)
728 && (!NILP (Fget_char_property (new_pos
, Qfield
, Qnil
))
729 || !NILP (Fget_char_property (old_pos
, Qfield
, Qnil
)))
730 && (NILP (inhibit_capture_property
)
731 || NILP (Fget_char_property(old_pos
, inhibit_capture_property
, Qnil
))))
732 /* NEW_POS is not within the same field as OLD_POS; try to
733 move NEW_POS so that it is. */
736 Lisp_Object field_bound
;
738 CHECK_NUMBER_COERCE_MARKER (new_pos
);
739 CHECK_NUMBER_COERCE_MARKER (old_pos
);
741 fwd
= (XFASTINT (new_pos
) > XFASTINT (old_pos
));
744 field_bound
= Ffield_end (old_pos
, escape_from_edge
, new_pos
);
746 field_bound
= Ffield_beginning (old_pos
, escape_from_edge
, new_pos
);
748 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
749 other side of NEW_POS, which would mean that NEW_POS is
750 already acceptable, and it's not necessary to constrain it
752 ((XFASTINT (field_bound
) < XFASTINT (new_pos
)) ? fwd
: !fwd
)
753 /* NEW_POS should be constrained, but only if either
754 ONLY_IN_LINE is nil (in which case any constraint is OK),
755 or NEW_POS and FIELD_BOUND are on the same line (in which
756 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
757 && (NILP (only_in_line
)
758 /* This is the ONLY_IN_LINE case, check that NEW_POS and
759 FIELD_BOUND are on the same line by seeing whether
760 there's an intervening newline or not. */
761 || (scan_buffer ('\n',
762 XFASTINT (new_pos
), XFASTINT (field_bound
),
763 fwd
? -1 : 1, &shortage
, 1),
765 /* Constrain NEW_POS to FIELD_BOUND. */
766 new_pos
= field_bound
;
768 if (orig_point
&& XFASTINT (new_pos
) != orig_point
)
769 /* The NEW_POS argument was originally nil, so automatically set PT. */
770 SET_PT (XFASTINT (new_pos
));
777 DEFUN ("line-beginning-position",
778 Fline_beginning_position
, Sline_beginning_position
, 0, 1, 0,
779 doc
: /* Return the character position of the first character on the current line.
780 With argument N not nil or 1, move forward N - 1 lines first.
781 If scan reaches end of buffer, return that position.
783 The scan does not cross a field boundary unless doing so would move
784 beyond there to a different line; if N is nil or 1, and scan starts at a
785 field boundary, the scan stops as soon as it starts. To ignore field
786 boundaries bind `inhibit-field-text-motion' to t.
788 This function does not move point. */)
792 int orig
, orig_byte
, end
;
801 Fforward_line (make_number (XINT (n
) - 1));
804 SET_PT_BOTH (orig
, orig_byte
);
806 /* Return END constrained to the current input field. */
807 return Fconstrain_to_field (make_number (end
), make_number (orig
),
808 XINT (n
) != 1 ? Qt
: Qnil
,
812 DEFUN ("line-end-position", Fline_end_position
, Sline_end_position
, 0, 1, 0,
813 doc
: /* Return the character position of the last character on the current line.
814 With argument N not nil or 1, move forward N - 1 lines first.
815 If scan reaches end of buffer, return that position.
817 The scan does not cross a field boundary unless doing so would move
818 beyond there to a different line; if N is nil or 1, and scan starts at a
819 field boundary, the scan stops as soon as it starts. To ignore field
820 boundaries bind `inhibit-field-text-motion' to t.
822 This function does not move point. */)
834 end_pos
= find_before_next_newline (orig
, 0, XINT (n
) - (XINT (n
) <= 0));
836 /* Return END_POS constrained to the current input field. */
837 return Fconstrain_to_field (make_number (end_pos
), make_number (orig
),
843 save_excursion_save ()
845 int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
848 return Fcons (Fpoint_marker (),
849 Fcons (Fcopy_marker (current_buffer
->mark
, Qnil
),
850 Fcons (visible
? Qt
: Qnil
,
851 Fcons (current_buffer
->mark_active
,
856 save_excursion_restore (info
)
859 Lisp_Object tem
, tem1
, omark
, nmark
;
860 struct gcpro gcpro1
, gcpro2
, gcpro3
;
863 tem
= Fmarker_buffer (XCAR (info
));
864 /* If buffer being returned to is now deleted, avoid error */
865 /* Otherwise could get error here while unwinding to top level
867 /* In that case, Fmarker_buffer returns nil now. */
871 omark
= nmark
= Qnil
;
872 GCPRO3 (info
, omark
, nmark
);
879 unchain_marker (XMARKER (tem
));
884 omark
= Fmarker_position (current_buffer
->mark
);
885 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
886 nmark
= Fmarker_position (tem
);
887 unchain_marker (XMARKER (tem
));
891 visible_p
= !NILP (XCAR (info
));
893 #if 0 /* We used to make the current buffer visible in the selected window
894 if that was true previously. That avoids some anomalies.
895 But it creates others, and it wasn't documented, and it is simpler
896 and cleaner never to alter the window/buffer connections. */
899 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
900 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
906 tem1
= current_buffer
->mark_active
;
907 current_buffer
->mark_active
= tem
;
909 if (!NILP (Vrun_hooks
))
911 /* If mark is active now, and either was not active
912 or was at a different place, run the activate hook. */
913 if (! NILP (current_buffer
->mark_active
))
915 if (! EQ (omark
, nmark
))
916 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
918 /* If mark has ceased to be active, run deactivate hook. */
919 else if (! NILP (tem1
))
920 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
923 /* If buffer was visible in a window, and a different window was
924 selected, and the old selected window is still showing this
925 buffer, restore point in that window. */
928 && !EQ (tem
, selected_window
)
929 && (tem1
= XWINDOW (tem
)->buffer
,
930 (/* Window is live... */
932 /* ...and it shows the current buffer. */
933 && XBUFFER (tem1
) == current_buffer
)))
934 Fset_window_point (tem
, make_number (PT
));
940 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
941 doc
: /* Save point, mark, and current buffer; execute BODY; restore those things.
942 Executes BODY just like `progn'.
943 The values of point, mark and the current buffer are restored
944 even in case of abnormal exit (throw or error).
945 The state of activation of the mark is also restored.
947 This construct does not save `deactivate-mark', and therefore
948 functions that change the buffer will still cause deactivation
949 of the mark at the end of the command. To prevent that, bind
950 `deactivate-mark' with `let'.
952 usage: (save-excursion &rest BODY) */)
956 register Lisp_Object val
;
957 int count
= SPECPDL_INDEX ();
959 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
962 return unbind_to (count
, val
);
965 DEFUN ("save-current-buffer", Fsave_current_buffer
, Ssave_current_buffer
, 0, UNEVALLED
, 0,
966 doc
: /* Save the current buffer; execute BODY; restore the current buffer.
967 Executes BODY just like `progn'.
968 usage: (save-current-buffer &rest BODY) */)
973 int count
= SPECPDL_INDEX ();
975 record_unwind_protect (set_buffer_if_live
, Fcurrent_buffer ());
978 return unbind_to (count
, val
);
981 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 1, 0,
982 doc
: /* Return the number of characters in the current buffer.
983 If BUFFER, return the number of characters in that buffer instead. */)
988 return make_number (Z
- BEG
);
991 CHECK_BUFFER (buffer
);
992 return make_number (BUF_Z (XBUFFER (buffer
))
993 - BUF_BEG (XBUFFER (buffer
)));
997 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
998 doc
: /* Return the minimum permissible value of point in the current buffer.
999 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1003 XSETFASTINT (temp
, BEGV
);
1007 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
1008 doc
: /* Return a marker to the minimum permissible value of point in this buffer.
1009 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1012 return buildmark (BEGV
, BEGV_BYTE
);
1015 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
1016 doc
: /* Return the maximum permissible value of point in the current buffer.
1017 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1018 is in effect, in which case it is less. */)
1022 XSETFASTINT (temp
, ZV
);
1026 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
1027 doc
: /* Return a marker to the maximum permissible value of point in this buffer.
1028 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1029 is in effect, in which case it is less. */)
1032 return buildmark (ZV
, ZV_BYTE
);
1035 DEFUN ("gap-position", Fgap_position
, Sgap_position
, 0, 0, 0,
1036 doc
: /* Return the position of the gap, in the current buffer.
1037 See also `gap-size'. */)
1041 XSETFASTINT (temp
, GPT
);
1045 DEFUN ("gap-size", Fgap_size
, Sgap_size
, 0, 0, 0,
1046 doc
: /* Return the size of the current buffer's gap.
1047 See also `gap-position'. */)
1051 XSETFASTINT (temp
, GAP_SIZE
);
1055 DEFUN ("position-bytes", Fposition_bytes
, Sposition_bytes
, 1, 1, 0,
1056 doc
: /* Return the byte position for character position POSITION.
1057 If POSITION is out of range, the value is nil. */)
1059 Lisp_Object position
;
1061 CHECK_NUMBER_COERCE_MARKER (position
);
1062 if (XINT (position
) < BEG
|| XINT (position
) > Z
)
1064 return make_number (CHAR_TO_BYTE (XINT (position
)));
1067 DEFUN ("byte-to-position", Fbyte_to_position
, Sbyte_to_position
, 1, 1, 0,
1068 doc
: /* Return the character position for byte position BYTEPOS.
1069 If BYTEPOS is out of range, the value is nil. */)
1071 Lisp_Object bytepos
;
1073 CHECK_NUMBER (bytepos
);
1074 if (XINT (bytepos
) < BEG_BYTE
|| XINT (bytepos
) > Z_BYTE
)
1076 return make_number (BYTE_TO_CHAR (XINT (bytepos
)));
1079 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
1080 doc
: /* Return the character following point, as a number.
1081 At the end of the buffer or accessible region, return 0. */)
1086 XSETFASTINT (temp
, 0);
1088 XSETFASTINT (temp
, FETCH_CHAR (PT_BYTE
));
1092 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
1093 doc
: /* Return the character preceding point, as a number.
1094 At the beginning of the buffer or accessible region, return 0. */)
1099 XSETFASTINT (temp
, 0);
1100 else if (!NILP (current_buffer
->enable_multibyte_characters
))
1104 XSETFASTINT (temp
, FETCH_CHAR (pos
));
1107 XSETFASTINT (temp
, FETCH_BYTE (PT_BYTE
- 1));
1111 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
1112 doc
: /* Return t if point is at the beginning of the buffer.
1113 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1121 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
1122 doc
: /* Return t if point is at the end of the buffer.
1123 If the buffer is narrowed, this means the end of the narrowed part. */)
1131 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
1132 doc
: /* Return t if point is at the beginning of a line. */)
1135 if (PT
== BEGV
|| FETCH_BYTE (PT_BYTE
- 1) == '\n')
1140 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
1141 doc
: /* Return t if point is at the end of a line.
1142 `End of a line' includes point being at the end of the buffer. */)
1145 if (PT
== ZV
|| FETCH_BYTE (PT_BYTE
) == '\n')
1150 DEFUN ("char-after", Fchar_after
, Schar_after
, 0, 1, 0,
1151 doc
: /* Return character in current buffer at position POS.
1152 POS is an integer or a marker and defaults to point.
1153 If POS is out of range, the value is nil. */)
1157 register int pos_byte
;
1162 XSETFASTINT (pos
, PT
);
1167 pos_byte
= marker_byte_position (pos
);
1168 if (pos_byte
< BEGV_BYTE
|| pos_byte
>= ZV_BYTE
)
1173 CHECK_NUMBER_COERCE_MARKER (pos
);
1174 if (XINT (pos
) < BEGV
|| XINT (pos
) >= ZV
)
1177 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1180 return make_number (FETCH_CHAR (pos_byte
));
1183 DEFUN ("char-before", Fchar_before
, Schar_before
, 0, 1, 0,
1184 doc
: /* Return character in current buffer preceding position POS.
1185 POS is an integer or a marker and defaults to point.
1186 If POS is out of range, the value is nil. */)
1190 register Lisp_Object val
;
1191 register int pos_byte
;
1196 XSETFASTINT (pos
, PT
);
1201 pos_byte
= marker_byte_position (pos
);
1203 if (pos_byte
<= BEGV_BYTE
|| pos_byte
> ZV_BYTE
)
1208 CHECK_NUMBER_COERCE_MARKER (pos
);
1210 if (XINT (pos
) <= BEGV
|| XINT (pos
) > ZV
)
1213 pos_byte
= CHAR_TO_BYTE (XINT (pos
));
1216 if (!NILP (current_buffer
->enable_multibyte_characters
))
1219 XSETFASTINT (val
, FETCH_CHAR (pos_byte
));
1224 XSETFASTINT (val
, FETCH_BYTE (pos_byte
));
1229 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
1230 doc
: /* Return the name under which the user logged in, as a string.
1231 This is based on the effective uid, not the real uid.
1232 Also, if the environment variables LOGNAME or USER are set,
1233 that determines the value of this function.
1235 If optional argument UID is an integer, return the login name of the user
1236 with that uid, or nil if there is no such user. */)
1242 /* Set up the user name info if we didn't do it before.
1243 (That can happen if Emacs is dumpable
1244 but you decide to run `temacs -l loadup' and not dump. */
1245 if (INTEGERP (Vuser_login_name
))
1249 return Vuser_login_name
;
1252 pw
= (struct passwd
*) getpwuid (XINT (uid
));
1253 return (pw
? build_string (pw
->pw_name
) : Qnil
);
1256 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
1258 doc
: /* Return the name of the user's real uid, as a string.
1259 This ignores the environment variables LOGNAME and USER, so it differs from
1260 `user-login-name' when running under `su'. */)
1263 /* Set up the user name info if we didn't do it before.
1264 (That can happen if Emacs is dumpable
1265 but you decide to run `temacs -l loadup' and not dump. */
1266 if (INTEGERP (Vuser_login_name
))
1268 return Vuser_real_login_name
;
1271 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
1272 doc
: /* Return the effective uid of Emacs.
1273 Value is an integer or float, depending on the value. */)
1276 return make_fixnum_or_float (geteuid ());
1279 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
1280 doc
: /* Return the real uid of Emacs.
1281 Value is an integer or float, depending on the value. */)
1284 return make_fixnum_or_float (getuid ());
1287 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 1, 0,
1288 doc
: /* Return the full name of the user logged in, as a string.
1289 If the full name corresponding to Emacs's userid is not known,
1292 If optional argument UID is an integer or float, return the full name
1293 of the user with that uid, or nil if there is no such user.
1294 If UID is a string, return the full name of the user with that login
1295 name, or nil if there is no such user. */)
1300 register unsigned char *p
, *q
;
1304 return Vuser_full_name
;
1305 else if (NUMBERP (uid
))
1306 pw
= (struct passwd
*) getpwuid ((uid_t
) XFLOATINT (uid
));
1307 else if (STRINGP (uid
))
1308 pw
= (struct passwd
*) getpwnam (SDATA (uid
));
1310 error ("Invalid UID specification");
1315 p
= (unsigned char *) USER_FULL_NAME
;
1316 /* Chop off everything after the first comma. */
1317 q
= (unsigned char *) index (p
, ',');
1318 full
= make_string (p
, q
? q
- p
: strlen (p
));
1320 #ifdef AMPERSAND_FULL_NAME
1322 q
= (unsigned char *) index (p
, '&');
1323 /* Substitute the login name for the &, upcasing the first character. */
1326 register unsigned char *r
;
1329 login
= Fuser_login_name (make_number (pw
->pw_uid
));
1330 r
= (unsigned char *) alloca (strlen (p
) + SCHARS (login
) + 1);
1331 bcopy (p
, r
, q
- p
);
1333 strcat (r
, SDATA (login
));
1334 r
[q
- p
] = UPCASE (r
[q
- p
]);
1336 full
= build_string (r
);
1338 #endif /* AMPERSAND_FULL_NAME */
1343 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
1344 doc
: /* Return the name of the machine you are running on, as a string. */)
1347 return Vsystem_name
;
1350 /* For the benefit of callers who don't want to include lisp.h */
1355 if (STRINGP (Vsystem_name
))
1356 return (char *) SDATA (Vsystem_name
);
1362 get_operating_system_release()
1364 if (STRINGP (Voperating_system_release
))
1365 return (char *) SDATA (Voperating_system_release
);
1370 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
1371 doc
: /* Return the process ID of Emacs, as an integer. */)
1374 return make_number (getpid ());
1377 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
1378 doc
: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1379 The time is returned as a list of three integers. The first has the
1380 most significant 16 bits of the seconds, while the second has the
1381 least significant 16 bits. The third integer gives the microsecond
1384 The microsecond count is zero on systems that do not provide
1385 resolution finer than a second. */)
1389 Lisp_Object result
[3];
1392 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
1393 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
1394 XSETINT (result
[2], EMACS_USECS (t
));
1396 return Flist (3, result
);
1399 DEFUN ("get-internal-run-time", Fget_internal_run_time
, Sget_internal_run_time
,
1401 doc
: /* Return the current run time used by Emacs.
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 On systems that can't determine the run time, get-internal-run-time
1408 does the same thing as current-time. The microsecond count is zero on
1409 systems that do not provide resolution finer than a second. */)
1412 #ifdef HAVE_GETRUSAGE
1413 struct rusage usage
;
1414 Lisp_Object result
[3];
1417 if (getrusage (RUSAGE_SELF
, &usage
) < 0)
1418 /* This shouldn't happen. What action is appropriate? */
1419 Fsignal (Qerror
, Qnil
);
1421 /* Sum up user time and system time. */
1422 secs
= usage
.ru_utime
.tv_sec
+ usage
.ru_stime
.tv_sec
;
1423 usecs
= usage
.ru_utime
.tv_usec
+ usage
.ru_stime
.tv_usec
;
1424 if (usecs
>= 1000000)
1430 XSETINT (result
[0], (secs
>> 16) & 0xffff);
1431 XSETINT (result
[1], (secs
>> 0) & 0xffff);
1432 XSETINT (result
[2], usecs
);
1434 return Flist (3, result
);
1436 return Fcurrent_time ();
1442 lisp_time_argument (specified_time
, result
, usec
)
1443 Lisp_Object specified_time
;
1447 if (NILP (specified_time
))
1454 *usec
= EMACS_USECS (t
);
1455 *result
= EMACS_SECS (t
);
1459 return time (result
) != -1;
1463 Lisp_Object high
, low
;
1464 high
= Fcar (specified_time
);
1465 CHECK_NUMBER (high
);
1466 low
= Fcdr (specified_time
);
1471 Lisp_Object usec_l
= Fcdr (low
);
1473 usec_l
= Fcar (usec_l
);
1478 CHECK_NUMBER (usec_l
);
1479 *usec
= XINT (usec_l
);
1487 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
1488 return *result
>> 16 == XINT (high
);
1492 DEFUN ("float-time", Ffloat_time
, Sfloat_time
, 0, 1, 0,
1493 doc
: /* Return the current time, as a float number of seconds since the epoch.
1494 If SPECIFIED-TIME is given, it is the time to convert to float
1495 instead of the current time. The argument should have the form
1496 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1497 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1498 have the form (HIGH . LOW), but this is considered obsolete.
1500 WARNING: Since the result is floating point, it may not be exact.
1501 Do not use this function if precise time stamps are required. */)
1503 Lisp_Object specified_time
;
1508 if (! lisp_time_argument (specified_time
, &sec
, &usec
))
1509 error ("Invalid time specification");
1511 return make_float ((sec
* 1e6
+ usec
) / 1e6
);
1514 /* Write information into buffer S of size MAXSIZE, according to the
1515 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1516 Default to Universal Time if UT is nonzero, local time otherwise.
1517 Return the number of bytes written, not including the terminating
1518 '\0'. If S is NULL, nothing will be written anywhere; so to
1519 determine how many bytes would be written, use NULL for S and
1520 ((size_t) -1) for MAXSIZE.
1522 This function behaves like emacs_strftimeu, except it allows null
1525 emacs_memftimeu (s
, maxsize
, format
, format_len
, tp
, ut
)
1530 const struct tm
*tp
;
1535 /* Loop through all the null-terminated strings in the format
1536 argument. Normally there's just one null-terminated string, but
1537 there can be arbitrarily many, concatenated together, if the
1538 format contains '\0' bytes. emacs_strftimeu stops at the first
1539 '\0' byte so we must invoke it separately for each such string. */
1548 result
= emacs_strftimeu (s
, maxsize
, format
, tp
, ut
);
1552 if (result
== 0 && s
[0] != '\0')
1557 maxsize
-= result
+ 1;
1559 len
= strlen (format
);
1560 if (len
== format_len
)
1564 format_len
-= len
+ 1;
1568 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 1, 3, 0,
1569 doc
: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1570 TIME is specified as (HIGH LOW . IGNORED), as returned by
1571 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1572 is also still accepted.
1573 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1574 as Universal Time; nil means describe TIME in the local time zone.
1575 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1576 by text that describes the specified date and time in TIME:
1578 %Y is the year, %y within the century, %C the century.
1579 %G is the year corresponding to the ISO week, %g within the century.
1580 %m is the numeric month.
1581 %b and %h are the locale's abbreviated month name, %B the full name.
1582 %d is the day of the month, zero-padded, %e is blank-padded.
1583 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1584 %a is the locale's abbreviated name of the day of week, %A the full name.
1585 %U is the week number starting on Sunday, %W starting on Monday,
1586 %V according to ISO 8601.
1587 %j is the day of the year.
1589 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1590 only blank-padded, %l is like %I blank-padded.
1591 %p is the locale's equivalent of either AM or PM.
1594 %Z is the time zone name, %z is the numeric form.
1595 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1597 %c is the locale's date and time format.
1598 %x is the locale's "preferred" date format.
1599 %D is like "%m/%d/%y".
1601 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1602 %X is the locale's "preferred" time format.
1604 Finally, %n is a newline, %t is a tab, %% is a literal %.
1606 Certain flags and modifiers are available with some format controls.
1607 The flags are `_', `-', `^' and `#'. For certain characters X,
1608 %_X is like %X, but padded with blanks; %-X is like %X,
1609 but without padding. %^X is like %X, but with all textual
1610 characters up-cased; %#X is like %X, but with letter-case of
1611 all textual characters reversed.
1612 %NX (where N stands for an integer) is like %X,
1613 but takes up at least N (a number) positions.
1614 The modifiers are `E' and `O'. For certain characters X,
1615 %EX is a locale's alternative version of %X;
1616 %OX is like %X, but uses the locale's number symbols.
1618 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1619 (format_string
, time
, universal
)
1620 Lisp_Object format_string
, time
, universal
;
1625 int ut
= ! NILP (universal
);
1627 CHECK_STRING (format_string
);
1629 if (! lisp_time_argument (time
, &value
, NULL
))
1630 error ("Invalid time specification");
1632 format_string
= code_convert_string_norecord (format_string
,
1633 Vlocale_coding_system
, 1);
1635 /* This is probably enough. */
1636 size
= SBYTES (format_string
) * 6 + 50;
1638 tm
= ut
? gmtime (&value
) : localtime (&value
);
1640 error ("Specified time is not representable");
1642 synchronize_system_time_locale ();
1646 char *buf
= (char *) alloca (size
+ 1);
1650 result
= emacs_memftimeu (buf
, size
, SDATA (format_string
),
1651 SBYTES (format_string
),
1653 if ((result
> 0 && result
< size
) || (result
== 0 && buf
[0] == '\0'))
1654 return code_convert_string_norecord (make_string (buf
, result
),
1655 Vlocale_coding_system
, 0);
1657 /* If buffer was too small, make it bigger and try again. */
1658 result
= emacs_memftimeu (NULL
, (size_t) -1,
1659 SDATA (format_string
),
1660 SBYTES (format_string
),
1666 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
1667 doc
: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1668 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1669 as from `current-time' and `file-attributes', or `nil' to use the
1670 current time. The obsolete form (HIGH . LOW) is also still accepted.
1671 The list has the following nine members: SEC is an integer between 0
1672 and 60; SEC is 60 for a leap second, which only some operating systems
1673 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1674 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1675 integer between 1 and 12. YEAR is an integer indicating the
1676 four-digit year. DOW is the day of week, an integer between 0 and 6,
1677 where 0 is Sunday. DST is t if daylight savings time is effect,
1678 otherwise nil. ZONE is an integer indicating the number of seconds
1679 east of Greenwich. (Note that Common Lisp has different meanings for
1682 Lisp_Object specified_time
;
1686 struct tm
*decoded_time
;
1687 Lisp_Object list_args
[9];
1689 if (! lisp_time_argument (specified_time
, &time_spec
, NULL
))
1690 error ("Invalid time specification");
1692 decoded_time
= localtime (&time_spec
);
1694 error ("Specified time is not representable");
1695 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
1696 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
1697 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
1698 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
1699 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
1700 XSETINT (list_args
[5], decoded_time
->tm_year
+ 1900);
1701 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
1702 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
1704 /* Make a copy, in case gmtime modifies the struct. */
1705 save_tm
= *decoded_time
;
1706 decoded_time
= gmtime (&time_spec
);
1707 if (decoded_time
== 0)
1708 list_args
[8] = Qnil
;
1710 XSETINT (list_args
[8], tm_diff (&save_tm
, decoded_time
));
1711 return Flist (9, list_args
);
1714 DEFUN ("encode-time", Fencode_time
, Sencode_time
, 6, MANY
, 0,
1715 doc
: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1716 This is the reverse operation of `decode-time', which see.
1717 ZONE defaults to the current time zone rule. This can
1718 be a string or t (as from `set-time-zone-rule'), or it can be a list
1719 \(as from `current-time-zone') or an integer (as from `decode-time')
1720 applied without consideration for daylight savings time.
1722 You can pass more than 7 arguments; then the first six arguments
1723 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1724 The intervening arguments are ignored.
1725 This feature lets (apply 'encode-time (decode-time ...)) work.
1727 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1728 for example, a DAY of 0 means the day preceding the given month.
1729 Year numbers less than 100 are treated just like other year numbers.
1730 If you want them to stand for years in this century, you must do that yourself.
1732 Years before 1970 are not guaranteed to work. On some systems,
1733 year values as low as 1901 do work.
1735 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1738 register Lisp_Object
*args
;
1742 Lisp_Object zone
= (nargs
> 6 ? args
[nargs
- 1] : Qnil
);
1744 CHECK_NUMBER (args
[0]); /* second */
1745 CHECK_NUMBER (args
[1]); /* minute */
1746 CHECK_NUMBER (args
[2]); /* hour */
1747 CHECK_NUMBER (args
[3]); /* day */
1748 CHECK_NUMBER (args
[4]); /* month */
1749 CHECK_NUMBER (args
[5]); /* year */
1751 tm
.tm_sec
= XINT (args
[0]);
1752 tm
.tm_min
= XINT (args
[1]);
1753 tm
.tm_hour
= XINT (args
[2]);
1754 tm
.tm_mday
= XINT (args
[3]);
1755 tm
.tm_mon
= XINT (args
[4]) - 1;
1756 tm
.tm_year
= XINT (args
[5]) - 1900;
1762 time
= mktime (&tm
);
1767 char **oldenv
= environ
, **newenv
;
1771 else if (STRINGP (zone
))
1772 tzstring
= (char *) SDATA (zone
);
1773 else if (INTEGERP (zone
))
1775 int abszone
= abs (XINT (zone
));
1776 sprintf (tzbuf
, "XXX%s%d:%02d:%02d", "-" + (XINT (zone
) < 0),
1777 abszone
/ (60*60), (abszone
/60) % 60, abszone
% 60);
1781 error ("Invalid time zone specification");
1783 /* Set TZ before calling mktime; merely adjusting mktime's returned
1784 value doesn't suffice, since that would mishandle leap seconds. */
1785 set_time_zone_rule (tzstring
);
1787 time
= mktime (&tm
);
1789 /* Restore TZ to previous value. */
1793 #ifdef LOCALTIME_CACHE
1798 if (time
== (time_t) -1)
1799 error ("Specified time is not representable");
1801 return make_time (time
);
1804 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
1805 doc
: /* Return the current time, as a human-readable string.
1806 Programs can use this function to decode a time,
1807 since the number of columns in each field is fixed.
1808 The format is `Sun Sep 16 01:03:52 1973'.
1809 However, see also the functions `decode-time' and `format-time-string'
1810 which provide a much more powerful and general facility.
1812 If SPECIFIED-TIME is given, it is a time to format instead of the
1813 current time. The argument should have the form (HIGH LOW . IGNORED).
1814 Thus, you can use times obtained from `current-time' and from
1815 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1816 but this is considered obsolete. */)
1818 Lisp_Object specified_time
;
1824 if (! lisp_time_argument (specified_time
, &value
, NULL
))
1826 tem
= (char *) ctime (&value
);
1828 strncpy (buf
, tem
, 24);
1831 return build_string (buf
);
1834 #define TM_YEAR_BASE 1900
1836 /* Yield A - B, measured in seconds.
1837 This function is copied from the GNU C Library. */
1842 /* Compute intervening leap days correctly even if year is negative.
1843 Take care to avoid int overflow in leap day calculations,
1844 but it's OK to assume that A and B are close to each other. */
1845 int a4
= (a
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (a
->tm_year
& 3);
1846 int b4
= (b
->tm_year
>> 2) + (TM_YEAR_BASE
>> 2) - ! (b
->tm_year
& 3);
1847 int a100
= a4
/ 25 - (a4
% 25 < 0);
1848 int b100
= b4
/ 25 - (b4
% 25 < 0);
1849 int a400
= a100
>> 2;
1850 int b400
= b100
>> 2;
1851 int intervening_leap_days
= (a4
- b4
) - (a100
- b100
) + (a400
- b400
);
1852 int years
= a
->tm_year
- b
->tm_year
;
1853 int days
= (365 * years
+ intervening_leap_days
1854 + (a
->tm_yday
- b
->tm_yday
));
1855 return (60 * (60 * (24 * days
+ (a
->tm_hour
- b
->tm_hour
))
1856 + (a
->tm_min
- b
->tm_min
))
1857 + (a
->tm_sec
- b
->tm_sec
));
1860 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
1861 doc
: /* Return the offset and name for the local time zone.
1862 This returns a list of the form (OFFSET NAME).
1863 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1864 A negative value means west of Greenwich.
1865 NAME is a string giving the name of the time zone.
1866 If SPECIFIED-TIME is given, the time zone offset is determined from it
1867 instead of using the current time. The argument should have the form
1868 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1869 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1870 have the form (HIGH . LOW), but this is considered obsolete.
1872 Some operating systems cannot provide all this information to Emacs;
1873 in this case, `current-time-zone' returns a list containing nil for
1874 the data it can't find. */)
1876 Lisp_Object specified_time
;
1882 if (lisp_time_argument (specified_time
, &value
, NULL
)
1883 && (t
= gmtime (&value
)) != 0
1884 && (gmt
= *t
, t
= localtime (&value
)) != 0)
1886 int offset
= tm_diff (t
, &gmt
);
1891 s
= (char *)t
->tm_zone
;
1892 #else /* not HAVE_TM_ZONE */
1894 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
1895 s
= tzname
[t
->tm_isdst
];
1897 #endif /* not HAVE_TM_ZONE */
1899 #if defined HAVE_TM_ZONE || defined HAVE_TZNAME
1902 /* On Japanese w32, we can get a Japanese string as time
1903 zone name. Don't accept that. */
1905 for (p
= s
; *p
&& (isalnum ((unsigned char)*p
) || *p
== ' '); ++p
)
1914 /* No local time zone name is available; use "+-NNNN" instead. */
1915 int am
= (offset
< 0 ? -offset
: offset
) / 60;
1916 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
1919 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
1922 return Fmake_list (make_number (2), Qnil
);
1925 /* This holds the value of `environ' produced by the previous
1926 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
1927 has never been called. */
1928 static char **environbuf
;
1930 DEFUN ("set-time-zone-rule", Fset_time_zone_rule
, Sset_time_zone_rule
, 1, 1, 0,
1931 doc
: /* Set the local time zone using TZ, a string specifying a time zone rule.
1932 If TZ is nil, use implementation-defined default time zone information.
1933 If TZ is t, use Universal Time. */)
1941 else if (EQ (tz
, Qt
))
1946 tzstring
= (char *) SDATA (tz
);
1949 set_time_zone_rule (tzstring
);
1952 environbuf
= environ
;
1957 #ifdef LOCALTIME_CACHE
1959 /* These two values are known to load tz files in buggy implementations,
1960 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
1961 Their values shouldn't matter in non-buggy implementations.
1962 We don't use string literals for these strings,
1963 since if a string in the environment is in readonly
1964 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
1965 See Sun bugs 1113095 and 1114114, ``Timezone routines
1966 improperly modify environment''. */
1968 static char set_time_zone_rule_tz1
[] = "TZ=GMT+0";
1969 static char set_time_zone_rule_tz2
[] = "TZ=GMT+1";
1973 /* Set the local time zone rule to TZSTRING.
1974 This allocates memory into `environ', which it is the caller's
1975 responsibility to free. */
1978 set_time_zone_rule (tzstring
)
1982 char **from
, **to
, **newenv
;
1984 /* Make the ENVIRON vector longer with room for TZSTRING. */
1985 for (from
= environ
; *from
; from
++)
1987 envptrs
= from
- environ
+ 2;
1988 newenv
= to
= (char **) xmalloc (envptrs
* sizeof (char *)
1989 + (tzstring
? strlen (tzstring
) + 4 : 0));
1991 /* Add TZSTRING to the end of environ, as a value for TZ. */
1994 char *t
= (char *) (to
+ envptrs
);
1996 strcat (t
, tzstring
);
2000 /* Copy the old environ vector elements into NEWENV,
2001 but don't copy the TZ variable.
2002 So we have only one definition of TZ, which came from TZSTRING. */
2003 for (from
= environ
; *from
; from
++)
2004 if (strncmp (*from
, "TZ=", 3) != 0)
2010 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2011 the TZ variable is stored. If we do not have a TZSTRING,
2012 TO points to the vector slot which has the terminating null. */
2014 #ifdef LOCALTIME_CACHE
2016 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2017 "US/Pacific" that loads a tz file, then changes to a value like
2018 "XXX0" that does not load a tz file, and then changes back to
2019 its original value, the last change is (incorrectly) ignored.
2020 Also, if TZ changes twice in succession to values that do
2021 not load a tz file, tzset can dump core (see Sun bug#1225179).
2022 The following code works around these bugs. */
2026 /* Temporarily set TZ to a value that loads a tz file
2027 and that differs from tzstring. */
2029 *newenv
= (strcmp (tzstring
, set_time_zone_rule_tz1
+ 3) == 0
2030 ? set_time_zone_rule_tz2
: set_time_zone_rule_tz1
);
2036 /* The implied tzstring is unknown, so temporarily set TZ to
2037 two different values that each load a tz file. */
2038 *to
= set_time_zone_rule_tz1
;
2041 *to
= set_time_zone_rule_tz2
;
2046 /* Now TZ has the desired value, and tzset can be invoked safely. */
2053 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2054 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2055 type of object is Lisp_String). INHERIT is passed to
2056 INSERT_FROM_STRING_FUNC as the last argument. */
2059 general_insert_function (insert_func
, insert_from_string_func
,
2060 inherit
, nargs
, args
)
2061 void (*insert_func
) P_ ((const unsigned char *, int));
2062 void (*insert_from_string_func
) P_ ((Lisp_Object
, int, int, int, int, int));
2064 register Lisp_Object
*args
;
2066 register int argnum
;
2067 register Lisp_Object val
;
2069 for (argnum
= 0; argnum
< nargs
; argnum
++)
2075 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2078 if (!NILP (current_buffer
->enable_multibyte_characters
))
2079 len
= CHAR_STRING (XFASTINT (val
), str
);
2082 str
[0] = (ASCII_CHAR_P (XINT (val
))
2084 : multibyte_char_to_unibyte (XINT (val
), Qnil
));
2087 (*insert_func
) (str
, len
);
2089 else if (STRINGP (val
))
2091 (*insert_from_string_func
) (val
, 0, 0,
2098 val
= wrong_type_argument (Qchar_or_string_p
, val
);
2112 /* Callers passing one argument to Finsert need not gcpro the
2113 argument "array", since the only element of the array will
2114 not be used after calling insert or insert_from_string, so
2115 we don't care if it gets trashed. */
2117 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
2118 doc
: /* Insert the arguments, either strings or characters, at point.
2119 Point and before-insertion markers move forward to end up
2120 after the inserted text.
2121 Any other markers at the point of insertion remain before the text.
2123 If the current buffer is multibyte, unibyte strings are converted
2124 to multibyte for insertion (see `string-make-multibyte').
2125 If the current buffer is unibyte, multibyte strings are converted
2126 to unibyte for insertion (see `string-make-unibyte').
2128 When operating on binary data, it may be necessary to preserve the
2129 original bytes of a unibyte string when inserting it into a multibyte
2130 buffer; to accomplish this, apply `string-as-multibyte' to the string
2131 and insert the result.
2133 usage: (insert &rest ARGS) */)
2136 register Lisp_Object
*args
;
2138 general_insert_function (insert
, insert_from_string
, 0, nargs
, args
);
2142 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
2144 doc
: /* Insert the arguments at point, inheriting properties from adjoining text.
2145 Point and before-insertion markers move forward to end up
2146 after the inserted text.
2147 Any other markers at the point of insertion remain before the text.
2149 If the current buffer is multibyte, unibyte strings are converted
2150 to multibyte for insertion (see `unibyte-char-to-multibyte').
2151 If the current buffer is unibyte, multibyte strings are converted
2152 to unibyte for insertion.
2154 usage: (insert-and-inherit &rest ARGS) */)
2157 register Lisp_Object
*args
;
2159 general_insert_function (insert_and_inherit
, insert_from_string
, 1,
2164 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
2165 doc
: /* Insert strings or characters at point, relocating markers after the text.
2166 Point and markers move forward to end up after the inserted text.
2168 If the current buffer is multibyte, unibyte strings are converted
2169 to multibyte for insertion (see `unibyte-char-to-multibyte').
2170 If the current buffer is unibyte, multibyte strings are converted
2171 to unibyte for insertion.
2173 usage: (insert-before-markers &rest ARGS) */)
2176 register Lisp_Object
*args
;
2178 general_insert_function (insert_before_markers
,
2179 insert_from_string_before_markers
, 0,
2184 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers
,
2185 Sinsert_and_inherit_before_markers
, 0, MANY
, 0,
2186 doc
: /* Insert text at point, relocating markers and inheriting properties.
2187 Point and markers move forward to end up after the inserted text.
2189 If the current buffer is multibyte, unibyte strings are converted
2190 to multibyte for insertion (see `unibyte-char-to-multibyte').
2191 If the current buffer is unibyte, multibyte strings are converted
2192 to unibyte for insertion.
2194 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2197 register Lisp_Object
*args
;
2199 general_insert_function (insert_before_markers_and_inherit
,
2200 insert_from_string_before_markers
, 1,
2205 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
2206 doc
: /* Insert COUNT (second arg) copies of CHARACTER (first arg).
2207 Both arguments are required.
2208 Point, and before-insertion markers, are relocated as in the function `insert'.
2209 The optional third arg INHERIT, if non-nil, says to inherit text properties
2210 from adjoining text, if those properties are sticky. */)
2211 (character
, count
, inherit
)
2212 Lisp_Object character
, count
, inherit
;
2214 register unsigned char *string
;
2215 register int strlen
;
2218 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2220 CHECK_NUMBER (character
);
2221 CHECK_NUMBER (count
);
2223 if (!NILP (current_buffer
->enable_multibyte_characters
))
2224 len
= CHAR_STRING (XFASTINT (character
), str
);
2226 str
[0] = XFASTINT (character
), len
= 1;
2227 n
= XINT (count
) * len
;
2230 strlen
= min (n
, 256 * len
);
2231 string
= (unsigned char *) alloca (strlen
);
2232 for (i
= 0; i
< strlen
; i
++)
2233 string
[i
] = str
[i
% len
];
2237 if (!NILP (inherit
))
2238 insert_and_inherit (string
, strlen
);
2240 insert (string
, strlen
);
2245 if (!NILP (inherit
))
2246 insert_and_inherit (string
, n
);
2253 DEFUN ("insert-byte", Finsert_byte
, Sinsert_byte
, 2, 3, 0,
2254 doc
: /* Insert COUNT (second arg) copies of BYTE (first arg).
2255 Both arguments are required.
2256 BYTE is a number of the range 0..255.
2258 If BYTE is 128..255 and the current buffer is multibyte, the
2259 corresponding eight-bit character is inserted.
2261 Point, and before-insertion markers, are relocated as in the function `insert'.
2262 The optional third arg INHERIT, if non-nil, says to inherit text properties
2263 from adjoining text, if those properties are sticky. */)
2264 (byte
, count
, inherit
)
2265 Lisp_Object byte
, count
, inherit
;
2267 CHECK_NUMBER (byte
);
2268 if (XINT (byte
) < 0 || XINT (byte
) > 255)
2269 args_out_of_range_3 (byte
, make_number (0), make_number (255));
2270 if (XINT (byte
) >= 128
2271 && ! NILP (current_buffer
->enable_multibyte_characters
))
2272 XSETFASTINT (byte
, BYTE8_TO_CHAR (XINT (byte
)));
2273 return Finsert_char (byte
, count
, inherit
);
2277 /* Making strings from buffer contents. */
2279 /* Return a Lisp_String containing the text of the current buffer from
2280 START to END. If text properties are in use and the current buffer
2281 has properties in the range specified, the resulting string will also
2282 have them, if PROPS is nonzero.
2284 We don't want to use plain old make_string here, because it calls
2285 make_uninit_string, which can cause the buffer arena to be
2286 compacted. make_string has no way of knowing that the data has
2287 been moved, and thus copies the wrong data into the string. This
2288 doesn't effect most of the other users of make_string, so it should
2289 be left as is. But we should use this function when conjuring
2290 buffer substrings. */
2293 make_buffer_string (start
, end
, props
)
2297 int start_byte
= CHAR_TO_BYTE (start
);
2298 int end_byte
= CHAR_TO_BYTE (end
);
2300 return make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
);
2303 /* Return a Lisp_String containing the text of the current buffer from
2304 START / START_BYTE to END / END_BYTE.
2306 If text properties are in use and the current buffer
2307 has properties in the range specified, the resulting string will also
2308 have them, if PROPS is nonzero.
2310 We don't want to use plain old make_string here, because it calls
2311 make_uninit_string, which can cause the buffer arena to be
2312 compacted. make_string has no way of knowing that the data has
2313 been moved, and thus copies the wrong data into the string. This
2314 doesn't effect most of the other users of make_string, so it should
2315 be left as is. But we should use this function when conjuring
2316 buffer substrings. */
2319 make_buffer_string_both (start
, start_byte
, end
, end_byte
, props
)
2320 int start
, start_byte
, end
, end_byte
;
2323 Lisp_Object result
, tem
, tem1
;
2325 if (start
< GPT
&& GPT
< end
)
2328 if (! NILP (current_buffer
->enable_multibyte_characters
))
2329 result
= make_uninit_multibyte_string (end
- start
, end_byte
- start_byte
);
2331 result
= make_uninit_string (end
- start
);
2332 bcopy (BYTE_POS_ADDR (start_byte
), SDATA (result
),
2333 end_byte
- start_byte
);
2335 /* If desired, update and copy the text properties. */
2338 update_buffer_properties (start
, end
);
2340 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
2341 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
2343 if (XINT (tem
) != end
|| !NILP (tem1
))
2344 copy_intervals_to_string (result
, current_buffer
, start
,
2351 /* Call Vbuffer_access_fontify_functions for the range START ... END
2352 in the current buffer, if necessary. */
2355 update_buffer_properties (start
, end
)
2358 /* If this buffer has some access functions,
2359 call them, specifying the range of the buffer being accessed. */
2360 if (!NILP (Vbuffer_access_fontify_functions
))
2362 Lisp_Object args
[3];
2365 args
[0] = Qbuffer_access_fontify_functions
;
2366 XSETINT (args
[1], start
);
2367 XSETINT (args
[2], end
);
2369 /* But don't call them if we can tell that the work
2370 has already been done. */
2371 if (!NILP (Vbuffer_access_fontified_property
))
2373 tem
= Ftext_property_any (args
[1], args
[2],
2374 Vbuffer_access_fontified_property
,
2377 Frun_hook_with_args (3, args
);
2380 Frun_hook_with_args (3, args
);
2384 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
2385 doc
: /* Return the contents of part of the current buffer as a string.
2386 The two arguments START and END are character positions;
2387 they can be in either order.
2388 The string returned is multibyte if the buffer is multibyte.
2390 This function copies the text properties of that part of the buffer
2391 into the result string; if you don't want the text properties,
2392 use `buffer-substring-no-properties' instead. */)
2394 Lisp_Object start
, end
;
2398 validate_region (&start
, &end
);
2402 return make_buffer_string (b
, e
, 1);
2405 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties
,
2406 Sbuffer_substring_no_properties
, 2, 2, 0,
2407 doc
: /* Return the characters of part of the buffer, without the text properties.
2408 The two arguments START and END are character positions;
2409 they can be in either order. */)
2411 Lisp_Object start
, end
;
2415 validate_region (&start
, &end
);
2419 return make_buffer_string (b
, e
, 0);
2422 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
2423 doc
: /* Return the contents of the current buffer as a string.
2424 If narrowing is in effect, this function returns only the visible part
2428 return make_buffer_string (BEGV
, ZV
, 1);
2431 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
2433 doc
: /* Insert before point a substring of the contents of BUFFER.
2434 BUFFER may be a buffer or a buffer name.
2435 Arguments START and END are character positions specifying the substring.
2436 They default to the values of (point-min) and (point-max) in BUFFER. */)
2437 (buffer
, start
, end
)
2438 Lisp_Object buffer
, start
, end
;
2440 register int b
, e
, temp
;
2441 register struct buffer
*bp
, *obuf
;
2444 buf
= Fget_buffer (buffer
);
2448 if (NILP (bp
->name
))
2449 error ("Selecting deleted buffer");
2455 CHECK_NUMBER_COERCE_MARKER (start
);
2462 CHECK_NUMBER_COERCE_MARKER (end
);
2467 temp
= b
, b
= e
, e
= temp
;
2469 if (!(BUF_BEGV (bp
) <= b
&& e
<= BUF_ZV (bp
)))
2470 args_out_of_range (start
, end
);
2472 obuf
= current_buffer
;
2473 set_buffer_internal_1 (bp
);
2474 update_buffer_properties (b
, e
);
2475 set_buffer_internal_1 (obuf
);
2477 insert_from_buffer (bp
, b
, e
- b
, 0);
2481 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
2483 doc
: /* Compare two substrings of two buffers; return result as number.
2484 the value is -N if first string is less after N-1 chars,
2485 +N if first string is greater after N-1 chars, or 0 if strings match.
2486 Each substring is represented as three arguments: BUFFER, START and END.
2487 That makes six args in all, three for each substring.
2489 The value of `case-fold-search' in the current buffer
2490 determines whether case is significant or ignored. */)
2491 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
2492 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
2494 register int begp1
, endp1
, begp2
, endp2
, temp
;
2495 register struct buffer
*bp1
, *bp2
;
2496 register Lisp_Object
*trt
2497 = (!NILP (current_buffer
->case_fold_search
)
2498 ? XCHAR_TABLE (current_buffer
->case_canon_table
)->contents
: 0);
2500 int i1
, i2
, i1_byte
, i2_byte
;
2502 /* Find the first buffer and its substring. */
2505 bp1
= current_buffer
;
2509 buf1
= Fget_buffer (buffer1
);
2512 bp1
= XBUFFER (buf1
);
2513 if (NILP (bp1
->name
))
2514 error ("Selecting deleted buffer");
2518 begp1
= BUF_BEGV (bp1
);
2521 CHECK_NUMBER_COERCE_MARKER (start1
);
2522 begp1
= XINT (start1
);
2525 endp1
= BUF_ZV (bp1
);
2528 CHECK_NUMBER_COERCE_MARKER (end1
);
2529 endp1
= XINT (end1
);
2533 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
2535 if (!(BUF_BEGV (bp1
) <= begp1
2537 && endp1
<= BUF_ZV (bp1
)))
2538 args_out_of_range (start1
, end1
);
2540 /* Likewise for second substring. */
2543 bp2
= current_buffer
;
2547 buf2
= Fget_buffer (buffer2
);
2550 bp2
= XBUFFER (buf2
);
2551 if (NILP (bp2
->name
))
2552 error ("Selecting deleted buffer");
2556 begp2
= BUF_BEGV (bp2
);
2559 CHECK_NUMBER_COERCE_MARKER (start2
);
2560 begp2
= XINT (start2
);
2563 endp2
= BUF_ZV (bp2
);
2566 CHECK_NUMBER_COERCE_MARKER (end2
);
2567 endp2
= XINT (end2
);
2571 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
2573 if (!(BUF_BEGV (bp2
) <= begp2
2575 && endp2
<= BUF_ZV (bp2
)))
2576 args_out_of_range (start2
, end2
);
2580 i1_byte
= buf_charpos_to_bytepos (bp1
, i1
);
2581 i2_byte
= buf_charpos_to_bytepos (bp2
, i2
);
2583 while (i1
< endp1
&& i2
< endp2
)
2585 /* When we find a mismatch, we must compare the
2586 characters, not just the bytes. */
2591 if (! NILP (bp1
->enable_multibyte_characters
))
2593 c1
= BUF_FETCH_MULTIBYTE_CHAR (bp1
, i1_byte
);
2594 BUF_INC_POS (bp1
, i1_byte
);
2599 c1
= BUF_FETCH_BYTE (bp1
, i1
);
2600 c1
= unibyte_char_to_multibyte (c1
);
2604 if (! NILP (bp2
->enable_multibyte_characters
))
2606 c2
= BUF_FETCH_MULTIBYTE_CHAR (bp2
, i2_byte
);
2607 BUF_INC_POS (bp2
, i2_byte
);
2612 c2
= BUF_FETCH_BYTE (bp2
, i2
);
2613 c2
= unibyte_char_to_multibyte (c2
);
2619 c1
= XINT (trt
[c1
]);
2620 c2
= XINT (trt
[c2
]);
2623 return make_number (- 1 - chars
);
2625 return make_number (chars
+ 1);
2630 /* The strings match as far as they go.
2631 If one is shorter, that one is less. */
2632 if (chars
< endp1
- begp1
)
2633 return make_number (chars
+ 1);
2634 else if (chars
< endp2
- begp2
)
2635 return make_number (- chars
- 1);
2637 /* Same length too => they are equal. */
2638 return make_number (0);
2642 subst_char_in_region_unwind (arg
)
2645 return current_buffer
->undo_list
= arg
;
2649 subst_char_in_region_unwind_1 (arg
)
2652 return current_buffer
->filename
= arg
;
2655 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
2656 Ssubst_char_in_region
, 4, 5, 0,
2657 doc
: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2658 If optional arg NOUNDO is non-nil, don't record this change for undo
2659 and don't mark the buffer as really changed.
2660 Both characters must have the same length of multi-byte form. */)
2661 (start
, end
, fromchar
, tochar
, noundo
)
2662 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
2664 register int pos
, pos_byte
, stop
, i
, len
, end_byte
;
2666 unsigned char fromstr
[MAX_MULTIBYTE_LENGTH
], tostr
[MAX_MULTIBYTE_LENGTH
];
2668 int count
= SPECPDL_INDEX ();
2669 #define COMBINING_NO 0
2670 #define COMBINING_BEFORE 1
2671 #define COMBINING_AFTER 2
2672 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2673 int maybe_byte_combining
= COMBINING_NO
;
2674 int last_changed
= 0;
2675 int multibyte_p
= !NILP (current_buffer
->enable_multibyte_characters
);
2677 validate_region (&start
, &end
);
2678 CHECK_NUMBER (fromchar
);
2679 CHECK_NUMBER (tochar
);
2683 len
= CHAR_STRING (XFASTINT (fromchar
), fromstr
);
2684 if (CHAR_STRING (XFASTINT (tochar
), tostr
) != len
)
2685 error ("Characters in `subst-char-in-region' have different byte-lengths");
2686 if (!ASCII_BYTE_P (*tostr
))
2688 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2689 complete multibyte character, it may be combined with the
2690 after bytes. If it is in the range 0xA0..0xFF, it may be
2691 combined with the before and after bytes. */
2692 if (!CHAR_HEAD_P (*tostr
))
2693 maybe_byte_combining
= COMBINING_BOTH
;
2694 else if (BYTES_BY_CHAR_HEAD (*tostr
) > len
)
2695 maybe_byte_combining
= COMBINING_AFTER
;
2701 fromstr
[0] = XFASTINT (fromchar
);
2702 tostr
[0] = XFASTINT (tochar
);
2706 pos_byte
= CHAR_TO_BYTE (pos
);
2707 stop
= CHAR_TO_BYTE (XINT (end
));
2710 /* If we don't want undo, turn off putting stuff on the list.
2711 That's faster than getting rid of things,
2712 and it prevents even the entry for a first change.
2713 Also inhibit locking the file. */
2716 record_unwind_protect (subst_char_in_region_unwind
,
2717 current_buffer
->undo_list
);
2718 current_buffer
->undo_list
= Qt
;
2719 /* Don't do file-locking. */
2720 record_unwind_protect (subst_char_in_region_unwind_1
,
2721 current_buffer
->filename
);
2722 current_buffer
->filename
= Qnil
;
2725 if (pos_byte
< GPT_BYTE
)
2726 stop
= min (stop
, GPT_BYTE
);
2729 int pos_byte_next
= pos_byte
;
2731 if (pos_byte
>= stop
)
2733 if (pos_byte
>= end_byte
) break;
2736 p
= BYTE_POS_ADDR (pos_byte
);
2738 INC_POS (pos_byte_next
);
2741 if (pos_byte_next
- pos_byte
== len
2742 && p
[0] == fromstr
[0]
2744 || (p
[1] == fromstr
[1]
2745 && (len
== 2 || (p
[2] == fromstr
[2]
2746 && (len
== 3 || p
[3] == fromstr
[3]))))))
2751 modify_region (current_buffer
, changed
, XINT (end
));
2753 if (! NILP (noundo
))
2755 if (MODIFF
- 1 == SAVE_MODIFF
)
2757 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
2758 current_buffer
->auto_save_modified
++;
2762 /* Take care of the case where the new character
2763 combines with neighboring bytes. */
2764 if (maybe_byte_combining
2765 && (maybe_byte_combining
== COMBINING_AFTER
2766 ? (pos_byte_next
< Z_BYTE
2767 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2768 : ((pos_byte_next
< Z_BYTE
2769 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next
)))
2770 || (pos_byte
> BEG_BYTE
2771 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte
- 1))))))
2773 Lisp_Object tem
, string
;
2775 struct gcpro gcpro1
;
2777 tem
= current_buffer
->undo_list
;
2780 /* Make a multibyte string containing this single character. */
2781 string
= make_multibyte_string (tostr
, 1, len
);
2782 /* replace_range is less efficient, because it moves the gap,
2783 but it handles combining correctly. */
2784 replace_range (pos
, pos
+ 1, string
,
2786 pos_byte_next
= CHAR_TO_BYTE (pos
);
2787 if (pos_byte_next
> pos_byte
)
2788 /* Before combining happened. We should not increment
2789 POS. So, to cancel the later increment of POS,
2793 INC_POS (pos_byte_next
);
2795 if (! NILP (noundo
))
2796 current_buffer
->undo_list
= tem
;
2803 record_change (pos
, 1);
2804 for (i
= 0; i
< len
; i
++) *p
++ = tostr
[i
];
2806 last_changed
= pos
+ 1;
2808 pos_byte
= pos_byte_next
;
2814 signal_after_change (changed
,
2815 last_changed
- changed
, last_changed
- changed
);
2816 update_compositions (changed
, last_changed
, CHECK_ALL
);
2819 unbind_to (count
, Qnil
);
2824 static Lisp_Object check_translation
P_ ((int, int, int, Lisp_Object
));
2826 /* Helper function for Ftranslate_region_internal.
2828 Check if a character sequence at POS (POS_BYTE) matches an element
2829 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2830 element is found, return it. Otherwise return Qnil. */
2833 check_translation (pos
, pos_byte
, end
, val
)
2834 int pos
, pos_byte
, end
;
2837 int buf_size
= 16, buf_used
= 0;
2838 int *buf
= alloca (sizeof (int) * buf_size
);
2840 for (; CONSP (val
); val
= XCDR (val
))
2849 if (! VECTORP (elt
))
2852 if (len
<= end
- pos
)
2854 for (i
= 0; i
< len
; i
++)
2858 unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2861 if (buf_used
== buf_size
)
2866 newbuf
= alloca (sizeof (int) * buf_size
);
2867 memcpy (newbuf
, buf
, sizeof (int) * buf_used
);
2870 buf
[buf_used
++] = STRING_CHAR_AND_LENGTH (p
, 0, len
);
2873 if (XINT (AREF (elt
, i
)) != buf
[i
])
2884 DEFUN ("translate-region-internal", Ftranslate_region_internal
,
2885 Stranslate_region_internal
, 3, 3, 0,
2886 doc
: /* Internal use only.
2887 From START to END, translate characters according to TABLE.
2888 TABLE is a string or a char-table; the Nth character in it is the
2889 mapping for the character with code N.
2890 It returns the number of characters changed. */)
2894 register Lisp_Object table
;
2896 register unsigned char *tt
; /* Trans table. */
2897 register int nc
; /* New character. */
2898 int cnt
; /* Number of changes made. */
2899 int size
; /* Size of translate table. */
2900 int pos
, pos_byte
, end_pos
;
2901 int multibyte
= !NILP (current_buffer
->enable_multibyte_characters
);
2902 int string_multibyte
;
2905 validate_region (&start
, &end
);
2906 if (CHAR_TABLE_P (table
))
2908 if (! EQ (XCHAR_TABLE (table
)->purpose
, Qtranslation_table
))
2909 error ("Not a translation table");
2915 CHECK_STRING (table
);
2917 if (! multibyte
&& (SCHARS (table
) < SBYTES (table
)))
2918 table
= string_make_unibyte (table
);
2919 string_multibyte
= SCHARS (table
) < SBYTES (table
);
2920 size
= SBYTES (table
);
2925 pos_byte
= CHAR_TO_BYTE (pos
);
2926 end_pos
= XINT (end
);
2927 modify_region (current_buffer
, pos
, end_pos
);
2930 for (; pos
< end_pos
; )
2932 register unsigned char *p
= BYTE_POS_ADDR (pos_byte
);
2933 unsigned char *str
, buf
[MAX_MULTIBYTE_LENGTH
];
2939 oc
= STRING_CHAR_AND_LENGTH (p
, MAX_MULTIBYTE_LENGTH
, len
);
2946 /* Reload as signal_after_change in last iteration may GC. */
2948 if (string_multibyte
)
2950 str
= tt
+ string_char_to_byte (table
, oc
);
2951 nc
= STRING_CHAR_AND_LENGTH (str
, MAX_MULTIBYTE_LENGTH
,
2957 if (! ASCII_BYTE_P (nc
) && multibyte
)
2959 str_len
= BYTE8_STRING (nc
, buf
);
2974 val
= CHAR_TABLE_REF (table
, oc
);
2975 if (CHARACTERP (val
)
2976 && (c
= XINT (val
), CHAR_VALID_P (c
, 0)))
2979 str_len
= CHAR_STRING (nc
, buf
);
2982 else if (VECTORP (val
) || (CONSP (val
)))
2984 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
2985 where TO is TO-CHAR or [TO-CHAR ...]. */
2990 if (nc
!= oc
&& nc
>= 0)
2992 /* Simple one char to one char translation. */
2997 /* This is less efficient, because it moves the gap,
2998 but it should handle multibyte characters correctly. */
2999 string
= make_multibyte_string (str
, 1, str_len
);
3000 replace_range (pos
, pos
+ 1, string
, 1, 0, 1);
3005 record_change (pos
, 1);
3006 while (str_len
-- > 0)
3008 signal_after_change (pos
, 1, 1);
3009 update_compositions (pos
, pos
+ 1, CHECK_BORDER
);
3019 val
= check_translation (pos
, pos_byte
, end_pos
, val
);
3026 /* VAL is ([FROM-CHAR ...] . TO). */
3027 len
= ASIZE (XCAR (val
));
3037 string
= Fmake_string (make_number (ASIZE (val
)),
3039 for (i
= 1; i
< ASIZE (val
); i
++)
3040 Faset (string
, make_number (i
), AREF (val
, i
));
3044 string
= Fmake_string (make_number (1), val
);
3046 replace_range (pos
, pos
+ len
, string
, 1, 0, 1);
3047 pos_byte
+= SBYTES (string
);
3048 pos
+= SCHARS (string
);
3049 cnt
+= SCHARS (string
);
3050 end_pos
+= SCHARS (string
) - len
;
3058 return make_number (cnt
);
3061 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
3062 doc
: /* Delete the text between point and mark.
3064 When called from a program, expects two arguments,
3065 positions (integers or markers) specifying the stretch to be deleted. */)
3067 Lisp_Object start
, end
;
3069 validate_region (&start
, &end
);
3070 del_range (XINT (start
), XINT (end
));
3074 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region
,
3075 Sdelete_and_extract_region
, 2, 2, 0,
3076 doc
: /* Delete the text between START and END and return it. */)
3078 Lisp_Object start
, end
;
3080 validate_region (&start
, &end
);
3081 if (XINT (start
) == XINT (end
))
3082 return build_string ("");
3083 return del_range_1 (XINT (start
), XINT (end
), 1, 1);
3086 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
3087 doc
: /* Remove restrictions (narrowing) from current buffer.
3088 This allows the buffer's full text to be seen and edited. */)
3091 if (BEG
!= BEGV
|| Z
!= ZV
)
3092 current_buffer
->clip_changed
= 1;
3094 BEGV_BYTE
= BEG_BYTE
;
3095 SET_BUF_ZV_BOTH (current_buffer
, Z
, Z_BYTE
);
3096 /* Changing the buffer bounds invalidates any recorded current column. */
3097 invalidate_current_column ();
3101 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
3102 doc
: /* Restrict editing in this buffer to the current region.
3103 The rest of the text becomes temporarily invisible and untouchable
3104 but is not deleted; if you save the buffer in a file, the invisible
3105 text is included in the file. \\[widen] makes all visible again.
3106 See also `save-restriction'.
3108 When calling from a program, pass two arguments; positions (integers
3109 or markers) bounding the text that should remain visible. */)
3111 register Lisp_Object start
, end
;
3113 CHECK_NUMBER_COERCE_MARKER (start
);
3114 CHECK_NUMBER_COERCE_MARKER (end
);
3116 if (XINT (start
) > XINT (end
))
3119 tem
= start
; start
= end
; end
= tem
;
3122 if (!(BEG
<= XINT (start
) && XINT (start
) <= XINT (end
) && XINT (end
) <= Z
))
3123 args_out_of_range (start
, end
);
3125 if (BEGV
!= XFASTINT (start
) || ZV
!= XFASTINT (end
))
3126 current_buffer
->clip_changed
= 1;
3128 SET_BUF_BEGV (current_buffer
, XFASTINT (start
));
3129 SET_BUF_ZV (current_buffer
, XFASTINT (end
));
3130 if (PT
< XFASTINT (start
))
3131 SET_PT (XFASTINT (start
));
3132 if (PT
> XFASTINT (end
))
3133 SET_PT (XFASTINT (end
));
3134 /* Changing the buffer bounds invalidates any recorded current column. */
3135 invalidate_current_column ();
3140 save_restriction_save ()
3142 if (BEGV
== BEG
&& ZV
== Z
)
3143 /* The common case that the buffer isn't narrowed.
3144 We return just the buffer object, which save_restriction_restore
3145 recognizes as meaning `no restriction'. */
3146 return Fcurrent_buffer ();
3148 /* We have to save a restriction, so return a pair of markers, one
3149 for the beginning and one for the end. */
3151 Lisp_Object beg
, end
;
3153 beg
= buildmark (BEGV
, BEGV_BYTE
);
3154 end
= buildmark (ZV
, ZV_BYTE
);
3156 /* END must move forward if text is inserted at its exact location. */
3157 XMARKER(end
)->insertion_type
= 1;
3159 return Fcons (beg
, end
);
3164 save_restriction_restore (data
)
3168 /* A pair of marks bounding a saved restriction. */
3170 struct Lisp_Marker
*beg
= XMARKER (XCAR (data
));
3171 struct Lisp_Marker
*end
= XMARKER (XCDR (data
));
3172 struct buffer
*buf
= beg
->buffer
; /* END should have the same buffer. */
3174 if (buf
/* Verify marker still points to a buffer. */
3175 && (beg
->charpos
!= BUF_BEGV (buf
) || end
->charpos
!= BUF_ZV (buf
)))
3176 /* The restriction has changed from the saved one, so restore
3177 the saved restriction. */
3179 int pt
= BUF_PT (buf
);
3181 SET_BUF_BEGV_BOTH (buf
, beg
->charpos
, beg
->bytepos
);
3182 SET_BUF_ZV_BOTH (buf
, end
->charpos
, end
->bytepos
);
3184 if (pt
< beg
->charpos
|| pt
> end
->charpos
)
3185 /* The point is outside the new visible range, move it inside. */
3186 SET_BUF_PT_BOTH (buf
,
3187 clip_to_bounds (beg
->charpos
, pt
, end
->charpos
),
3188 clip_to_bounds (beg
->bytepos
, BUF_PT_BYTE (buf
),
3191 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3195 /* A buffer, which means that there was no old restriction. */
3197 struct buffer
*buf
= XBUFFER (data
);
3199 if (buf
/* Verify marker still points to a buffer. */
3200 && (BUF_BEGV (buf
) != BUF_BEG (buf
) || BUF_ZV (buf
) != BUF_Z (buf
)))
3201 /* The buffer has been narrowed, get rid of the narrowing. */
3203 SET_BUF_BEGV_BOTH (buf
, BUF_BEG (buf
), BUF_BEG_BYTE (buf
));
3204 SET_BUF_ZV_BOTH (buf
, BUF_Z (buf
), BUF_Z_BYTE (buf
));
3206 buf
->clip_changed
= 1; /* Remember that the narrowing changed. */
3213 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
3214 doc
: /* Execute BODY, saving and restoring current buffer's restrictions.
3215 The buffer's restrictions make parts of the beginning and end invisible.
3216 (They are set up with `narrow-to-region' and eliminated with `widen'.)
3217 This special form, `save-restriction', saves the current buffer's restrictions
3218 when it is entered, and restores them when it is exited.
3219 So any `narrow-to-region' within BODY lasts only until the end of the form.
3220 The old restrictions settings are restored
3221 even in case of abnormal exit (throw or error).
3223 The value returned is the value of the last form in BODY.
3225 Note: if you are using both `save-excursion' and `save-restriction',
3226 use `save-excursion' outermost:
3227 (save-excursion (save-restriction ...))
3229 usage: (save-restriction &rest BODY) */)
3233 register Lisp_Object val
;
3234 int count
= SPECPDL_INDEX ();
3236 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
3237 val
= Fprogn (body
);
3238 return unbind_to (count
, val
);
3241 /* Buffer for the most recent text displayed by Fmessage_box. */
3242 static char *message_text
;
3244 /* Allocated length of that buffer. */
3245 static int message_length
;
3247 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
3248 doc
: /* Print a one-line message at the bottom of the screen.
3249 The message also goes into the `*Messages*' buffer.
3250 \(In keyboard macros, that's all it does.)
3252 The first argument is a format control string, and the rest are data
3253 to be formatted under control of the string. See `format' for details.
3255 If the first argument is nil or the empty string, the function clears
3256 any existing message; this lets the minibuffer contents show. See
3257 also `current-message'.
3259 usage: (message STRING &rest ARGS) */)
3265 || (STRINGP (args
[0])
3266 && SBYTES (args
[0]) == 0))
3273 register Lisp_Object val
;
3274 val
= Fformat (nargs
, args
);
3275 message3 (val
, SBYTES (val
), STRING_MULTIBYTE (val
));
3280 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
3281 doc
: /* Display a message, in a dialog box if possible.
3282 If a dialog box is not available, use the echo area.
3283 The first argument is a format control string, and the rest are data
3284 to be formatted under control of the string. See `format' for details.
3286 If the first argument is nil or the empty string, clear any existing
3287 message; let the minibuffer contents show.
3289 usage: (message-box STRING &rest ARGS) */)
3301 register Lisp_Object val
;
3302 val
= Fformat (nargs
, args
);
3304 /* The MS-DOS frames support popup menus even though they are
3305 not FRAME_WINDOW_P. */
3306 if (FRAME_WINDOW_P (XFRAME (selected_frame
))
3307 || FRAME_MSDOS_P (XFRAME (selected_frame
)))
3309 Lisp_Object pane
, menu
, obj
;
3310 struct gcpro gcpro1
;
3311 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
3313 menu
= Fcons (val
, pane
);
3314 obj
= Fx_popup_dialog (Qt
, menu
, Qt
);
3318 #endif /* HAVE_MENUS */
3319 /* Copy the data so that it won't move when we GC. */
3322 message_text
= (char *)xmalloc (80);
3323 message_length
= 80;
3325 if (SBYTES (val
) > message_length
)
3327 message_length
= SBYTES (val
);
3328 message_text
= (char *)xrealloc (message_text
, message_length
);
3330 bcopy (SDATA (val
), message_text
, SBYTES (val
));
3331 message2 (message_text
, SBYTES (val
),
3332 STRING_MULTIBYTE (val
));
3337 extern Lisp_Object last_nonmenu_event
;
3340 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
3341 doc
: /* Display a message in a dialog box or in the echo area.
3342 If this command was invoked with the mouse, use a dialog box if
3343 `use-dialog-box' is non-nil.
3344 Otherwise, use the echo area.
3345 The first argument is a format control string, and the rest are data
3346 to be formatted under control of the string. See `format' for details.
3348 If the first argument is nil or the empty string, clear any existing
3349 message; let the minibuffer contents show.
3351 usage: (message-or-box STRING &rest ARGS) */)
3357 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
3359 return Fmessage_box (nargs
, args
);
3361 return Fmessage (nargs
, args
);
3364 DEFUN ("current-message", Fcurrent_message
, Scurrent_message
, 0, 0, 0,
3365 doc
: /* Return the string currently displayed in the echo area, or nil if none. */)
3368 return current_message ();
3372 DEFUN ("propertize", Fpropertize
, Spropertize
, 1, MANY
, 0,
3373 doc
: /* Return a copy of STRING with text properties added.
3374 First argument is the string to copy.
3375 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3376 properties to add to the result.
3377 usage: (propertize STRING &rest PROPERTIES) */)
3382 Lisp_Object properties
, string
;
3383 struct gcpro gcpro1
, gcpro2
;
3386 /* Number of args must be odd. */
3387 if ((nargs
& 1) == 0 || nargs
< 1)
3388 error ("Wrong number of arguments");
3390 properties
= string
= Qnil
;
3391 GCPRO2 (properties
, string
);
3393 /* First argument must be a string. */
3394 CHECK_STRING (args
[0]);
3395 string
= Fcopy_sequence (args
[0]);
3397 for (i
= 1; i
< nargs
; i
+= 2)
3398 properties
= Fcons (args
[i
], Fcons (args
[i
+ 1], properties
));
3400 Fadd_text_properties (make_number (0),
3401 make_number (SCHARS (string
)),
3402 properties
, string
);
3403 RETURN_UNGCPRO (string
);
3407 /* Number of bytes that STRING will occupy when put into the result.
3408 MULTIBYTE is nonzero if the result should be multibyte. */
3410 #define CONVERTED_BYTE_SIZE(MULTIBYTE, STRING) \
3411 (((MULTIBYTE) && ! STRING_MULTIBYTE (STRING)) \
3412 ? count_size_as_multibyte (SDATA (STRING), SBYTES (STRING)) \
3415 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
3416 doc
: /* Format a string out of a control-string and arguments.
3417 The first argument is a control string.
3418 The other arguments are substituted into it to make the result, a string.
3419 It may contain %-sequences meaning to substitute the next argument.
3420 %s means print a string argument. Actually, prints any object, with `princ'.
3421 %d means print as number in decimal (%o octal, %x hex).
3422 %X is like %x, but uses upper case.
3423 %e means print a number in exponential notation.
3424 %f means print a number in decimal-point notation.
3425 %g means print a number in exponential notation
3426 or decimal-point notation, whichever uses fewer characters.
3427 %c means print a number as a single character.
3428 %S means print any object as an s-expression (using `prin1').
3429 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3430 Use %% to put a single % into the output.
3432 The basic structure of a %-sequence is
3433 % <flags> <width> <precision> character
3434 where flags is [- #0]+, width is [0-9]+, and precision is .[0-9]+
3436 usage: (format STRING &rest OBJECTS) */)
3439 register Lisp_Object
*args
;
3441 register int n
; /* The number of the next arg to substitute */
3442 register int total
; /* An estimate of the final length */
3444 register unsigned char *format
, *end
, *format_start
;
3446 /* Nonzero if the output should be a multibyte string,
3447 which is true if any of the inputs is one. */
3449 /* When we make a multibyte string, we must pay attention to the
3450 byte combining problem, i.e., a byte may be combined with a
3451 multibyte charcter of the previous string. This flag tells if we
3452 must consider such a situation or not. */
3453 int maybe_combine_byte
;
3454 unsigned char *this_format
;
3455 /* Precision for each spec, or -1, a flag value meaning no precision
3456 was given in that spec. Element 0, corresonding to the format
3457 string itself, will not be used. Element NARGS, corresponding to
3458 no argument, *will* be assigned to in the case that a `%' and `.'
3459 occur after the final format specifier. */
3460 int *precision
= (int *) (alloca((nargs
+ 1) * sizeof (int)));
3463 int arg_intervals
= 0;
3466 /* discarded[I] is 1 if byte I of the format
3467 string was not copied into the output.
3468 It is 2 if byte I was not the first byte of its character. */
3469 char *discarded
= 0;
3471 /* Each element records, for one argument,
3472 the start and end bytepos in the output string,
3473 and whether the argument is a string with intervals.
3474 info[0] is unused. Unused elements have -1 for start. */
3477 int start
, end
, intervals
;
3480 /* It should not be necessary to GCPRO ARGS, because
3481 the caller in the interpreter should take care of that. */
3483 /* Try to determine whether the result should be multibyte.
3484 This is not always right; sometimes the result needs to be multibyte
3485 because of an object that we will pass through prin1,
3486 and in that case, we won't know it here. */
3487 for (n
= 0; n
< nargs
; n
++)
3489 if (STRINGP (args
[n
]) && STRING_MULTIBYTE (args
[n
]))
3491 /* Piggyback on this loop to initialize precision[N]. */
3494 precision
[nargs
] = -1;
3496 CHECK_STRING (args
[0]);
3497 /* We may have to change "%S" to "%s". */
3498 args
[0] = Fcopy_sequence (args
[0]);
3500 /* GC should never happen here, so abort if it does. */
3503 /* If we start out planning a unibyte result,
3504 then discover it has to be multibyte, we jump back to retry.
3505 That can only happen from the first large while loop below. */
3508 format
= SDATA (args
[0]);
3509 format_start
= format
;
3510 end
= format
+ SBYTES (args
[0]);
3513 /* Make room in result for all the non-%-codes in the control string. */
3514 total
= 5 + CONVERTED_BYTE_SIZE (multibyte
, args
[0]) + 1;
3516 /* Allocate the info and discarded tables. */
3518 int nbytes
= (nargs
+1) * sizeof *info
;
3521 info
= (struct info
*) alloca (nbytes
);
3522 bzero (info
, nbytes
);
3523 for (i
= 0; i
<= nargs
; i
++)
3526 SAFE_ALLOCA (discarded
, char *, SBYTES (args
[0]));
3527 bzero (discarded
, SBYTES (args
[0]));
3530 /* Add to TOTAL enough space to hold the converted arguments. */
3533 while (format
!= end
)
3534 if (*format
++ == '%')
3537 int actual_width
= 0;
3538 unsigned char *this_format_start
= format
- 1;
3539 int field_width
= 0;
3541 /* General format specifications look like
3543 '%' [flags] [field-width] [precision] format
3548 field-width ::= [0-9]+
3549 precision ::= '.' [0-9]*
3551 If a field-width is specified, it specifies to which width
3552 the output should be padded with blanks, iff the output
3553 string is shorter than field-width.
3555 If precision is specified, it specifies the number of
3556 digits to print after the '.' for floats, or the max.
3557 number of chars to print from a string. */
3559 while (*format
&& index ("-0# ", *format
))
3562 if (*format
>= '0' && *format
<= '9')
3564 for (field_width
= 0; *format
>= '0' && *format
<= '9'; ++format
)
3565 field_width
= 10 * field_width
+ *format
- '0';
3568 /* N is not incremented for another few lines below, so refer to
3569 element N+1 (which might be precision[NARGS]). */
3573 for (precision
[n
+1] = 0; *format
>= '0' && *format
<= '9'; ++format
)
3574 precision
[n
+1] = 10 * precision
[n
+1] + *format
- '0';
3577 if (format
- this_format_start
+ 1 > longest_format
)
3578 longest_format
= format
- this_format_start
+ 1;
3581 error ("Format string ends in middle of format specifier");
3584 else if (++n
>= nargs
)
3585 error ("Not enough arguments for format string");
3586 else if (*format
== 'S')
3588 /* For `S', prin1 the argument and then treat like a string. */
3589 register Lisp_Object tem
;
3590 tem
= Fprin1_to_string (args
[n
], Qnil
);
3591 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3597 /* If we restart the loop, we should not come here again
3598 because args[n] is now a string and calling
3599 Fprin1_to_string on it produces superflous double
3600 quotes. So, change "%S" to "%s" now. */
3604 else if (SYMBOLP (args
[n
]))
3606 args
[n
] = SYMBOL_NAME (args
[n
]);
3607 if (STRING_MULTIBYTE (args
[n
]) && ! multibyte
)
3614 else if (STRINGP (args
[n
]))
3617 if (*format
!= 's' && *format
!= 'S')
3618 error ("Format specifier doesn't match argument type");
3619 /* In the case (PRECISION[N] > 0), THISSIZE may not need
3620 to be as large as is calculated here. Easy check for
3621 the case PRECISION = 0. */
3622 thissize
= precision
[n
] ? CONVERTED_BYTE_SIZE (multibyte
, args
[n
]) : 0;
3623 actual_width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3625 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
3626 else if (INTEGERP (args
[n
]) && *format
!= 's')
3628 /* The following loop assumes the Lisp type indicates
3629 the proper way to pass the argument.
3630 So make sure we have a flonum if the argument should
3632 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
3633 args
[n
] = Ffloat (args
[n
]);
3635 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3636 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3637 error ("Invalid format operation %%%c", *format
);
3642 if (! ASCII_CHAR_P (XINT (args
[n
]))
3643 /* Note: No one can remeber why we have to treat
3644 the character 0 as a multibyte character here.
3645 But, until it causes a real problem, let's
3647 || XINT (args
[n
]) == 0)
3654 args
[n
] = Fchar_to_string (args
[n
]);
3655 thissize
= SBYTES (args
[n
]);
3657 else if (! ASCII_BYTE_P (XINT (args
[n
])) && multibyte
)
3660 = Fchar_to_string (Funibyte_char_to_multibyte (args
[n
]));
3661 thissize
= SBYTES (args
[n
]);
3665 else if (FLOATP (args
[n
]) && *format
!= 's')
3667 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
3669 if (*format
!= 'd' && *format
!= 'o' && *format
!= 'x'
3670 && *format
!= 'i' && *format
!= 'X' && *format
!= 'c')
3671 error ("Invalid format operation %%%c", *format
);
3672 args
[n
] = Ftruncate (args
[n
], Qnil
);
3675 /* Note that we're using sprintf to print floats,
3676 so we have to take into account what that function
3678 /* Filter out flag value of -1. */
3679 thissize
= (MAX_10_EXP
+ 100
3680 + (precision
[n
] > 0 ? precision
[n
] : 0));
3684 /* Anything but a string, convert to a string using princ. */
3685 register Lisp_Object tem
;
3686 tem
= Fprin1_to_string (args
[n
], Qt
);
3687 if (STRING_MULTIBYTE (tem
) && ! multibyte
)
3696 thissize
+= max (0, field_width
- actual_width
);
3697 total
+= thissize
+ 4;
3702 /* Now we can no longer jump to retry.
3703 TOTAL and LONGEST_FORMAT are known for certain. */
3705 this_format
= (unsigned char *) alloca (longest_format
+ 1);
3707 /* Allocate the space for the result.
3708 Note that TOTAL is an overestimate. */
3709 SAFE_ALLOCA (buf
, char *, total
);
3715 /* Scan the format and store result in BUF. */
3716 format
= SDATA (args
[0]);
3717 format_start
= format
;
3718 end
= format
+ SBYTES (args
[0]);
3719 maybe_combine_byte
= 0;
3720 while (format
!= end
)
3726 unsigned char *this_format_start
= format
;
3728 discarded
[format
- format_start
] = 1;
3731 while (index("-0# ", *format
))
3737 discarded
[format
- format_start
] = 1;
3741 minlen
= atoi (format
);
3743 while ((*format
>= '0' && *format
<= '9') || *format
== '.')
3745 discarded
[format
- format_start
] = 1;
3749 if (*format
++ == '%')
3758 discarded
[format
- format_start
- 1] = 1;
3759 info
[n
].start
= nchars
;
3761 if (STRINGP (args
[n
]))
3763 /* handle case (precision[n] >= 0) */
3766 int nbytes
, start
, end
;
3769 /* lisp_string_width ignores a precision of 0, but GNU
3770 libc functions print 0 characters when the precision
3771 is 0. Imitate libc behavior here. Changing
3772 lisp_string_width is the right thing, and will be
3773 done, but meanwhile we work with it. */
3775 if (precision
[n
] == 0)
3776 width
= nchars_string
= nbytes
= 0;
3777 else if (precision
[n
] > 0)
3778 width
= lisp_string_width (args
[n
], precision
[n
], &nchars_string
, &nbytes
);
3780 { /* no precision spec given for this argument */
3781 width
= lisp_string_width (args
[n
], -1, NULL
, NULL
);
3782 nbytes
= SBYTES (args
[n
]);
3783 nchars_string
= SCHARS (args
[n
]);
3786 /* If spec requires it, pad on right with spaces. */
3787 padding
= minlen
- width
;
3789 while (padding
-- > 0)
3796 nchars
+= nchars_string
;
3801 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3802 && STRING_MULTIBYTE (args
[n
])
3803 && !CHAR_HEAD_P (SREF (args
[n
], 0)))
3804 maybe_combine_byte
= 1;
3806 p
+= copy_text (SDATA (args
[n
]), p
,
3808 STRING_MULTIBYTE (args
[n
]), multibyte
);
3811 while (padding
-- > 0)
3817 /* If this argument has text properties, record where
3818 in the result string it appears. */
3819 if (STRING_INTERVALS (args
[n
]))
3820 info
[n
].intervals
= arg_intervals
= 1;
3822 else if (INTEGERP (args
[n
]) || FLOATP (args
[n
]))
3826 bcopy (this_format_start
, this_format
,
3827 format
- this_format_start
);
3828 this_format
[format
- this_format_start
] = 0;
3830 if (INTEGERP (args
[n
]))
3831 sprintf (p
, this_format
, XINT (args
[n
]));
3833 sprintf (p
, this_format
, XFLOAT_DATA (args
[n
]));
3837 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3838 && !CHAR_HEAD_P (*((unsigned char *) p
)))
3839 maybe_combine_byte
= 1;
3840 this_nchars
= strlen (p
);
3842 p
+= str_to_multibyte (p
, buf
+ total
- 1 - p
, this_nchars
);
3845 nchars
+= this_nchars
;
3848 info
[n
].end
= nchars
;
3850 else if (STRING_MULTIBYTE (args
[0]))
3852 /* Copy a whole multibyte character. */
3855 && !ASCII_BYTE_P (*((unsigned char *) p
- 1))
3856 && !CHAR_HEAD_P (*format
))
3857 maybe_combine_byte
= 1;
3859 while (! CHAR_HEAD_P (*format
))
3861 discarded
[format
- format_start
] = 2;
3868 /* Convert a single-byte character to multibyte. */
3869 int len
= copy_text (format
, p
, 1, 0, 1);
3876 *p
++ = *format
++, nchars
++;
3879 if (p
> buf
+ total
)
3882 if (maybe_combine_byte
)
3883 nchars
= multibyte_chars_in_text (buf
, p
- buf
);
3884 val
= make_specified_string (buf
, nchars
, p
- buf
, multibyte
);
3886 /* If we allocated BUF with malloc, free it too. */
3889 /* If the format string has text properties, or any of the string
3890 arguments has text properties, set up text properties of the
3893 if (STRING_INTERVALS (args
[0]) || arg_intervals
)
3895 Lisp_Object len
, new_len
, props
;
3896 struct gcpro gcpro1
;
3898 /* Add text properties from the format string. */
3899 len
= make_number (SCHARS (args
[0]));
3900 props
= text_property_list (args
[0], make_number (0), len
, Qnil
);
3905 int bytepos
= 0, position
= 0, translated
= 0, argn
= 1;
3908 /* Adjust the bounds of each text property
3909 to the proper start and end in the output string. */
3911 /* Put the positions in PROPS in increasing order, so that
3912 we can do (effectively) one scan through the position
3913 space of the format string. */
3914 props
= Fnreverse (props
);
3916 /* BYTEPOS is the byte position in the format string,
3917 POSITION is the untranslated char position in it,
3918 TRANSLATED is the translated char position in BUF,
3919 and ARGN is the number of the next arg we will come to. */
3920 for (list
= props
; CONSP (list
); list
= XCDR (list
))
3927 /* First adjust the property start position. */
3928 pos
= XINT (XCAR (item
));
3930 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
3931 up to this position. */
3932 for (; position
< pos
; bytepos
++)
3934 if (! discarded
[bytepos
])
3935 position
++, translated
++;
3936 else if (discarded
[bytepos
] == 1)
3939 if (translated
== info
[argn
].start
)
3941 translated
+= info
[argn
].end
- info
[argn
].start
;
3947 XSETCAR (item
, make_number (translated
));
3949 /* Likewise adjust the property end position. */
3950 pos
= XINT (XCAR (XCDR (item
)));
3952 for (; bytepos
< pos
; bytepos
++)
3954 if (! discarded
[bytepos
])
3955 position
++, translated
++;
3956 else if (discarded
[bytepos
] == 1)
3959 if (translated
== info
[argn
].start
)
3961 translated
+= info
[argn
].end
- info
[argn
].start
;
3967 XSETCAR (XCDR (item
), make_number (translated
));
3970 add_text_properties_from_list (val
, props
, make_number (0));
3973 /* Add text properties from arguments. */
3975 for (n
= 1; n
< nargs
; ++n
)
3976 if (info
[n
].intervals
)
3978 len
= make_number (SCHARS (args
[n
]));
3979 new_len
= make_number (info
[n
].end
- info
[n
].start
);
3980 props
= text_property_list (args
[n
], make_number (0), len
, Qnil
);
3981 extend_property_ranges (props
, len
, new_len
);
3982 /* If successive arguments have properites, be sure that
3983 the value of `composition' property be the copy. */
3984 if (n
> 1 && info
[n
- 1].end
)
3985 make_composition_value_copy (props
);
3986 add_text_properties_from_list (val
, props
,
3987 make_number (info
[n
].start
));
3997 format2 (string1
, arg0
, arg1
)
3999 Lisp_Object arg0
, arg1
;
4001 Lisp_Object args
[3];
4002 args
[0] = build_string (string1
);
4005 return Fformat (3, args
);
4008 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
4009 doc
: /* Return t if two characters match, optionally ignoring case.
4010 Both arguments must be characters (i.e. integers).
4011 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4013 register Lisp_Object c1
, c2
;
4019 if (XINT (c1
) == XINT (c2
))
4021 if (NILP (current_buffer
->case_fold_search
))
4024 /* Do these in separate statements,
4025 then compare the variables.
4026 because of the way DOWNCASE uses temp variables. */
4028 if (NILP (current_buffer
->enable_multibyte_characters
)
4029 && ! ASCII_CHAR_P (i1
))
4031 MAKE_CHAR_MULTIBYTE (i1
);
4034 if (NILP (current_buffer
->enable_multibyte_characters
)
4035 && ! ASCII_CHAR_P (i2
))
4037 MAKE_CHAR_MULTIBYTE (i2
);
4041 return (i1
== i2
? Qt
: Qnil
);
4044 /* Transpose the markers in two regions of the current buffer, and
4045 adjust the ones between them if necessary (i.e.: if the regions
4048 START1, END1 are the character positions of the first region.
4049 START1_BYTE, END1_BYTE are the byte positions.
4050 START2, END2 are the character positions of the second region.
4051 START2_BYTE, END2_BYTE are the byte positions.
4053 Traverses the entire marker list of the buffer to do so, adding an
4054 appropriate amount to some, subtracting from some, and leaving the
4055 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4057 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4060 transpose_markers (start1
, end1
, start2
, end2
,
4061 start1_byte
, end1_byte
, start2_byte
, end2_byte
)
4062 register int start1
, end1
, start2
, end2
;
4063 register int start1_byte
, end1_byte
, start2_byte
, end2_byte
;
4065 register int amt1
, amt1_byte
, amt2
, amt2_byte
, diff
, diff_byte
, mpos
;
4066 register struct Lisp_Marker
*marker
;
4068 /* Update point as if it were a marker. */
4072 TEMP_SET_PT_BOTH (PT
+ (end2
- end1
),
4073 PT_BYTE
+ (end2_byte
- end1_byte
));
4074 else if (PT
< start2
)
4075 TEMP_SET_PT_BOTH (PT
+ (end2
- start2
) - (end1
- start1
),
4076 (PT_BYTE
+ (end2_byte
- start2_byte
)
4077 - (end1_byte
- start1_byte
)));
4079 TEMP_SET_PT_BOTH (PT
- (start2
- start1
),
4080 PT_BYTE
- (start2_byte
- start1_byte
));
4082 /* We used to adjust the endpoints here to account for the gap, but that
4083 isn't good enough. Even if we assume the caller has tried to move the
4084 gap out of our way, it might still be at start1 exactly, for example;
4085 and that places it `inside' the interval, for our purposes. The amount
4086 of adjustment is nontrivial if there's a `denormalized' marker whose
4087 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4088 the dirty work to Fmarker_position, below. */
4090 /* The difference between the region's lengths */
4091 diff
= (end2
- start2
) - (end1
- start1
);
4092 diff_byte
= (end2_byte
- start2_byte
) - (end1_byte
- start1_byte
);
4094 /* For shifting each marker in a region by the length of the other
4095 region plus the distance between the regions. */
4096 amt1
= (end2
- start2
) + (start2
- end1
);
4097 amt2
= (end1
- start1
) + (start2
- end1
);
4098 amt1_byte
= (end2_byte
- start2_byte
) + (start2_byte
- end1_byte
);
4099 amt2_byte
= (end1_byte
- start1_byte
) + (start2_byte
- end1_byte
);
4101 for (marker
= BUF_MARKERS (current_buffer
); marker
; marker
= marker
->next
)
4103 mpos
= marker
->bytepos
;
4104 if (mpos
>= start1_byte
&& mpos
< end2_byte
)
4106 if (mpos
< end1_byte
)
4108 else if (mpos
< start2_byte
)
4112 marker
->bytepos
= mpos
;
4114 mpos
= marker
->charpos
;
4115 if (mpos
>= start1
&& mpos
< end2
)
4119 else if (mpos
< start2
)
4124 marker
->charpos
= mpos
;
4128 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
4129 doc
: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4130 The regions may not be overlapping, because the size of the buffer is
4131 never changed in a transposition.
4133 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4134 any markers that happen to be located in the regions.
4136 Transposing beyond buffer boundaries is an error. */)
4137 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
4138 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
4140 register int start1
, end1
, start2
, end2
;
4141 int start1_byte
, start2_byte
, len1_byte
, len2_byte
;
4142 int gap
, len1
, len_mid
, len2
;
4143 unsigned char *start1_addr
, *start2_addr
, *temp
;
4145 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
4146 cur_intv
= BUF_INTERVALS (current_buffer
);
4148 validate_region (&startr1
, &endr1
);
4149 validate_region (&startr2
, &endr2
);
4151 start1
= XFASTINT (startr1
);
4152 end1
= XFASTINT (endr1
);
4153 start2
= XFASTINT (startr2
);
4154 end2
= XFASTINT (endr2
);
4157 /* Swap the regions if they're reversed. */
4160 register int glumph
= start1
;
4168 len1
= end1
- start1
;
4169 len2
= end2
- start2
;
4172 error ("Transposed regions overlap");
4173 else if (start1
== end1
|| start2
== end2
)
4174 error ("Transposed region has length 0");
4176 /* The possibilities are:
4177 1. Adjacent (contiguous) regions, or separate but equal regions
4178 (no, really equal, in this case!), or
4179 2. Separate regions of unequal size.
4181 The worst case is usually No. 2. It means that (aside from
4182 potential need for getting the gap out of the way), there also
4183 needs to be a shifting of the text between the two regions. So
4184 if they are spread far apart, we are that much slower... sigh. */
4186 /* It must be pointed out that the really studly thing to do would
4187 be not to move the gap at all, but to leave it in place and work
4188 around it if necessary. This would be extremely efficient,
4189 especially considering that people are likely to do
4190 transpositions near where they are working interactively, which
4191 is exactly where the gap would be found. However, such code
4192 would be much harder to write and to read. So, if you are
4193 reading this comment and are feeling squirrely, by all means have
4194 a go! I just didn't feel like doing it, so I will simply move
4195 the gap the minimum distance to get it out of the way, and then
4196 deal with an unbroken array. */
4198 /* Make sure the gap won't interfere, by moving it out of the text
4199 we will operate on. */
4200 if (start1
< gap
&& gap
< end2
)
4202 if (gap
- start1
< end2
- gap
)
4208 start1_byte
= CHAR_TO_BYTE (start1
);
4209 start2_byte
= CHAR_TO_BYTE (start2
);
4210 len1_byte
= CHAR_TO_BYTE (end1
) - start1_byte
;
4211 len2_byte
= CHAR_TO_BYTE (end2
) - start2_byte
;
4213 #ifdef BYTE_COMBINING_DEBUG
4216 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4217 len2_byte
, start1
, start1_byte
)
4218 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4219 len1_byte
, end2
, start2_byte
+ len2_byte
)
4220 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4221 len1_byte
, end2
, start2_byte
+ len2_byte
))
4226 if (count_combining_before (BYTE_POS_ADDR (start2_byte
),
4227 len2_byte
, start1
, start1_byte
)
4228 || count_combining_before (BYTE_POS_ADDR (start1_byte
),
4229 len1_byte
, start2
, start2_byte
)
4230 || count_combining_after (BYTE_POS_ADDR (start2_byte
),
4231 len2_byte
, end1
, start1_byte
+ len1_byte
)
4232 || count_combining_after (BYTE_POS_ADDR (start1_byte
),
4233 len1_byte
, end2
, start2_byte
+ len2_byte
))
4238 /* Hmmm... how about checking to see if the gap is large
4239 enough to use as the temporary storage? That would avoid an
4240 allocation... interesting. Later, don't fool with it now. */
4242 /* Working without memmove, for portability (sigh), so must be
4243 careful of overlapping subsections of the array... */
4245 if (end1
== start2
) /* adjacent regions */
4247 modify_region (current_buffer
, start1
, end2
);
4248 record_change (start1
, len1
+ len2
);
4250 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4251 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4252 Fset_text_properties (make_number (start1
), make_number (end2
),
4255 /* First region smaller than second. */
4256 if (len1_byte
< len2_byte
)
4260 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4262 /* Don't precompute these addresses. We have to compute them
4263 at the last minute, because the relocating allocator might
4264 have moved the buffer around during the xmalloc. */
4265 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4266 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4268 bcopy (start2_addr
, temp
, len2_byte
);
4269 bcopy (start1_addr
, start1_addr
+ len2_byte
, len1_byte
);
4270 bcopy (temp
, start1_addr
, len2_byte
);
4274 /* First region not smaller than second. */
4278 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4279 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4280 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4281 bcopy (start1_addr
, temp
, len1_byte
);
4282 bcopy (start2_addr
, start1_addr
, len2_byte
);
4283 bcopy (temp
, start1_addr
+ len2_byte
, len1_byte
);
4286 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
4287 len1
, current_buffer
, 0);
4288 graft_intervals_into_buffer (tmp_interval2
, start1
,
4289 len2
, current_buffer
, 0);
4290 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4291 update_compositions (start1
+ len2
, end2
, CHECK_TAIL
);
4293 /* Non-adjacent regions, because end1 != start2, bleagh... */
4296 len_mid
= start2_byte
- (start1_byte
+ len1_byte
);
4298 if (len1_byte
== len2_byte
)
4299 /* Regions are same size, though, how nice. */
4303 modify_region (current_buffer
, start1
, end1
);
4304 modify_region (current_buffer
, start2
, end2
);
4305 record_change (start1
, len1
);
4306 record_change (start2
, len2
);
4307 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4308 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4309 Fset_text_properties (make_number (start1
), make_number (end1
),
4311 Fset_text_properties (make_number (start2
), make_number (end2
),
4314 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4315 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4316 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4317 bcopy (start1_addr
, temp
, len1_byte
);
4318 bcopy (start2_addr
, start1_addr
, len2_byte
);
4319 bcopy (temp
, start2_addr
, len1_byte
);
4322 graft_intervals_into_buffer (tmp_interval1
, start2
,
4323 len1
, current_buffer
, 0);
4324 graft_intervals_into_buffer (tmp_interval2
, start1
,
4325 len2
, current_buffer
, 0);
4328 else if (len1_byte
< len2_byte
) /* Second region larger than first */
4329 /* Non-adjacent & unequal size, area between must also be shifted. */
4333 modify_region (current_buffer
, start1
, end2
);
4334 record_change (start1
, (end2
- start1
));
4335 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4336 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4337 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4338 Fset_text_properties (make_number (start1
), make_number (end2
),
4341 /* holds region 2 */
4342 SAFE_ALLOCA (temp
, unsigned char *, len2_byte
);
4343 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4344 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4345 bcopy (start2_addr
, temp
, len2_byte
);
4346 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2_byte
, len1_byte
);
4347 safe_bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4348 bcopy (temp
, start1_addr
, len2_byte
);
4351 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4352 len1
, current_buffer
, 0);
4353 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4354 len_mid
, current_buffer
, 0);
4355 graft_intervals_into_buffer (tmp_interval2
, start1
,
4356 len2
, current_buffer
, 0);
4359 /* Second region smaller than first. */
4363 record_change (start1
, (end2
- start1
));
4364 modify_region (current_buffer
, start1
, end2
);
4366 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
4367 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
4368 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
4369 Fset_text_properties (make_number (start1
), make_number (end2
),
4372 /* holds region 1 */
4373 SAFE_ALLOCA (temp
, unsigned char *, len1_byte
);
4374 start1_addr
= BYTE_POS_ADDR (start1_byte
);
4375 start2_addr
= BYTE_POS_ADDR (start2_byte
);
4376 bcopy (start1_addr
, temp
, len1_byte
);
4377 bcopy (start2_addr
, start1_addr
, len2_byte
);
4378 bcopy (start1_addr
+ len1_byte
, start1_addr
+ len2_byte
, len_mid
);
4379 bcopy (temp
, start1_addr
+ len2_byte
+ len_mid
, len1_byte
);
4382 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
4383 len1
, current_buffer
, 0);
4384 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
4385 len_mid
, current_buffer
, 0);
4386 graft_intervals_into_buffer (tmp_interval2
, start1
,
4387 len2
, current_buffer
, 0);
4390 update_compositions (start1
, start1
+ len2
, CHECK_BORDER
);
4391 update_compositions (end2
- len1
, end2
, CHECK_BORDER
);
4394 /* When doing multiple transpositions, it might be nice
4395 to optimize this. Perhaps the markers in any one buffer
4396 should be organized in some sorted data tree. */
4397 if (NILP (leave_markers
))
4399 transpose_markers (start1
, end1
, start2
, end2
,
4400 start1_byte
, start1_byte
+ len1_byte
,
4401 start2_byte
, start2_byte
+ len2_byte
);
4402 fix_start_end_in_overlays (start1
, end2
);
4414 Qbuffer_access_fontify_functions
4415 = intern ("buffer-access-fontify-functions");
4416 staticpro (&Qbuffer_access_fontify_functions
);
4418 DEFVAR_LISP ("inhibit-field-text-motion", &Vinhibit_field_text_motion
,
4419 doc
: /* Non-nil means text motion commands don't notice fields. */);
4420 Vinhibit_field_text_motion
= Qnil
;
4422 DEFVAR_LISP ("buffer-access-fontify-functions",
4423 &Vbuffer_access_fontify_functions
,
4424 doc
: /* List of functions called by `buffer-substring' to fontify if necessary.
4425 Each function is called with two arguments which specify the range
4426 of the buffer being accessed. */);
4427 Vbuffer_access_fontify_functions
= Qnil
;
4431 extern Lisp_Object Vprin1_to_string_buffer
;
4432 obuf
= Fcurrent_buffer ();
4433 /* Do this here, because init_buffer_once is too early--it won't work. */
4434 Fset_buffer (Vprin1_to_string_buffer
);
4435 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4436 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
4441 DEFVAR_LISP ("buffer-access-fontified-property",
4442 &Vbuffer_access_fontified_property
,
4443 doc
: /* Property which (if non-nil) indicates text has been fontified.
4444 `buffer-substring' need not call the `buffer-access-fontify-functions'
4445 functions if all the text being accessed has this property. */);
4446 Vbuffer_access_fontified_property
= Qnil
;
4448 DEFVAR_LISP ("system-name", &Vsystem_name
,
4449 doc
: /* The name of the machine Emacs is running on. */);
4451 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
4452 doc
: /* The full name of the user logged in. */);
4454 DEFVAR_LISP ("user-login-name", &Vuser_login_name
,
4455 doc
: /* The user's name, taken from environment variables if possible. */);
4457 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name
,
4458 doc
: /* The user's name, based upon the real uid only. */);
4460 DEFVAR_LISP ("operating-system-release", &Voperating_system_release
,
4461 doc
: /* The release of the operating system Emacs is running on. */);
4463 defsubr (&Spropertize
);
4464 defsubr (&Schar_equal
);
4465 defsubr (&Sgoto_char
);
4466 defsubr (&Sstring_to_char
);
4467 defsubr (&Schar_to_string
);
4468 defsubr (&Sbuffer_substring
);
4469 defsubr (&Sbuffer_substring_no_properties
);
4470 defsubr (&Sbuffer_string
);
4472 defsubr (&Spoint_marker
);
4473 defsubr (&Smark_marker
);
4475 defsubr (&Sregion_beginning
);
4476 defsubr (&Sregion_end
);
4478 staticpro (&Qfield
);
4479 Qfield
= intern ("field");
4480 staticpro (&Qboundary
);
4481 Qboundary
= intern ("boundary");
4482 defsubr (&Sfield_beginning
);
4483 defsubr (&Sfield_end
);
4484 defsubr (&Sfield_string
);
4485 defsubr (&Sfield_string_no_properties
);
4486 defsubr (&Sdelete_field
);
4487 defsubr (&Sconstrain_to_field
);
4489 defsubr (&Sline_beginning_position
);
4490 defsubr (&Sline_end_position
);
4492 /* defsubr (&Smark); */
4493 /* defsubr (&Sset_mark); */
4494 defsubr (&Ssave_excursion
);
4495 defsubr (&Ssave_current_buffer
);
4497 defsubr (&Sbufsize
);
4498 defsubr (&Spoint_max
);
4499 defsubr (&Spoint_min
);
4500 defsubr (&Spoint_min_marker
);
4501 defsubr (&Spoint_max_marker
);
4502 defsubr (&Sgap_position
);
4503 defsubr (&Sgap_size
);
4504 defsubr (&Sposition_bytes
);
4505 defsubr (&Sbyte_to_position
);
4511 defsubr (&Sfollowing_char
);
4512 defsubr (&Sprevious_char
);
4513 defsubr (&Schar_after
);
4514 defsubr (&Schar_before
);
4516 defsubr (&Sinsert_before_markers
);
4517 defsubr (&Sinsert_and_inherit
);
4518 defsubr (&Sinsert_and_inherit_before_markers
);
4519 defsubr (&Sinsert_char
);
4520 defsubr (&Sinsert_byte
);
4522 defsubr (&Suser_login_name
);
4523 defsubr (&Suser_real_login_name
);
4524 defsubr (&Suser_uid
);
4525 defsubr (&Suser_real_uid
);
4526 defsubr (&Suser_full_name
);
4527 defsubr (&Semacs_pid
);
4528 defsubr (&Scurrent_time
);
4529 defsubr (&Sget_internal_run_time
);
4530 defsubr (&Sformat_time_string
);
4531 defsubr (&Sfloat_time
);
4532 defsubr (&Sdecode_time
);
4533 defsubr (&Sencode_time
);
4534 defsubr (&Scurrent_time_string
);
4535 defsubr (&Scurrent_time_zone
);
4536 defsubr (&Sset_time_zone_rule
);
4537 defsubr (&Ssystem_name
);
4538 defsubr (&Smessage
);
4539 defsubr (&Smessage_box
);
4540 defsubr (&Smessage_or_box
);
4541 defsubr (&Scurrent_message
);
4544 defsubr (&Sinsert_buffer_substring
);
4545 defsubr (&Scompare_buffer_substrings
);
4546 defsubr (&Ssubst_char_in_region
);
4547 defsubr (&Stranslate_region_internal
);
4548 defsubr (&Sdelete_region
);
4549 defsubr (&Sdelete_and_extract_region
);
4551 defsubr (&Snarrow_to_region
);
4552 defsubr (&Ssave_restriction
);
4553 defsubr (&Stranspose_regions
);
4556 /* arch-tag: fc3827d8-6f60-4067-b11e-c3218031b018
4557 (do not change this comment) */