Work around "Attempt to modify read-only object"
[emacs.git] / src / editfns.c
blob1686fbf668b9226eb63d3ee60569d4dadfdf24b8
1 /* Lisp functions pertaining to editing.
3 Copyright (C) 1985-1987, 1989, 1993-2015 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21 #include <config.h>
22 #include <sys/types.h>
23 #include <stdio.h>
25 #ifdef HAVE_PWD_H
26 #include <pwd.h>
27 #include <grp.h>
28 #endif
30 #include <unistd.h>
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
34 #endif
36 #include "lisp.h"
38 /* systime.h includes <sys/time.h> which, on some systems, is required
39 for <sys/resource.h>; thus systime.h must be included before
40 <sys/resource.h> */
41 #include "systime.h"
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
45 #endif
47 #include <float.h>
48 #include <limits.h>
49 #include <intprops.h>
50 #include <strftime.h>
51 #include <verify.h>
53 #include "intervals.h"
54 #include "character.h"
55 #include "buffer.h"
56 #include "coding.h"
57 #include "frame.h"
58 #include "window.h"
59 #include "blockinput.h"
61 #define TM_YEAR_BASE 1900
63 #ifdef WINDOWSNT
64 extern Lisp_Object w32_get_internal_run_time (void);
65 #endif
67 static struct lisp_time lisp_time_struct (Lisp_Object, int *);
68 static void set_time_zone_rule (char const *);
69 static Lisp_Object format_time_string (char const *, ptrdiff_t, struct timespec,
70 bool, struct tm *);
71 static long int tm_gmtoff (struct tm *);
72 static int tm_diff (struct tm *, struct tm *);
73 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
75 #ifndef HAVE_TM_GMTOFF
76 # define HAVE_TM_GMTOFF false
77 #endif
79 /* The startup value of the TZ environment variable; null if unset. */
80 static char const *initial_tz;
82 /* A valid but unlikely setting for the TZ environment variable.
83 It is OK (though a bit slower) if the user chooses this value. */
84 static char dump_tz_string[] = "TZ=UtC0";
86 /* The cached value of Vsystem_name. This is used only to compare it
87 to Vsystem_name, so it need not be visible to the GC. */
88 static Lisp_Object cached_system_name;
90 static void
91 init_and_cache_system_name (void)
93 init_system_name ();
94 cached_system_name = Vsystem_name;
97 void
98 init_editfns (void)
100 const char *user_name;
101 register char *p;
102 struct passwd *pw; /* password entry for the current user */
103 Lisp_Object tem;
105 /* Set up system_name even when dumping. */
106 init_and_cache_system_name ();
108 #ifndef CANNOT_DUMP
109 /* When just dumping out, set the time zone to a known unlikely value
110 and skip the rest of this function. */
111 if (!initialized)
113 # ifdef HAVE_TZSET
114 xputenv (dump_tz_string);
115 tzset ();
116 # endif
117 return;
119 #endif
121 char *tz = getenv ("TZ");
122 initial_tz = tz;
124 #if !defined CANNOT_DUMP && defined HAVE_TZSET
125 /* If the execution TZ happens to be the same as the dump TZ,
126 change it to some other value and then change it back,
127 to force the underlying implementation to reload the TZ info.
128 This is needed on implementations that load TZ info from files,
129 since the TZ file contents may differ between dump and execution. */
130 if (tz && strcmp (tz, &dump_tz_string[sizeof "TZ=" - 1]) == 0)
132 ++*tz;
133 tzset ();
134 --*tz;
136 #endif
138 /* Call set_time_zone_rule now, so that its call to putenv is done
139 before multiple threads are active. */
140 set_time_zone_rule (tz);
142 pw = getpwuid (getuid ());
143 #ifdef MSDOS
144 /* We let the real user name default to "root" because that's quite
145 accurate on MS-DOS and because it lets Emacs find the init file.
146 (The DVX libraries override the Djgpp libraries here.) */
147 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
148 #else
149 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
150 #endif
152 /* Get the effective user name, by consulting environment variables,
153 or the effective uid if those are unset. */
154 user_name = getenv ("LOGNAME");
155 if (!user_name)
156 #ifdef WINDOWSNT
157 user_name = getenv ("USERNAME"); /* it's USERNAME on NT */
158 #else /* WINDOWSNT */
159 user_name = getenv ("USER");
160 #endif /* WINDOWSNT */
161 if (!user_name)
163 pw = getpwuid (geteuid ());
164 user_name = pw ? pw->pw_name : "unknown";
166 Vuser_login_name = build_string (user_name);
168 /* If the user name claimed in the environment vars differs from
169 the real uid, use the claimed name to find the full name. */
170 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
171 if (! NILP (tem))
172 tem = Vuser_login_name;
173 else
175 uid_t euid = geteuid ();
176 tem = make_fixnum_or_float (euid);
178 Vuser_full_name = Fuser_full_name (tem);
180 p = getenv ("NAME");
181 if (p)
182 Vuser_full_name = build_string (p);
183 else if (NILP (Vuser_full_name))
184 Vuser_full_name = build_string ("unknown");
186 #ifdef HAVE_SYS_UTSNAME_H
188 struct utsname uts;
189 uname (&uts);
190 Voperating_system_release = build_string (uts.release);
192 #else
193 Voperating_system_release = Qnil;
194 #endif
197 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
198 doc: /* Convert arg CHAR to a string containing that character.
199 usage: (char-to-string CHAR) */)
200 (Lisp_Object character)
202 int c, len;
203 unsigned char str[MAX_MULTIBYTE_LENGTH];
205 CHECK_CHARACTER (character);
206 c = XFASTINT (character);
208 len = CHAR_STRING (c, str);
209 return make_string_from_bytes ((char *) str, 1, len);
212 DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
213 doc: /* Convert arg BYTE to a unibyte string containing that byte. */)
214 (Lisp_Object byte)
216 unsigned char b;
217 CHECK_NUMBER (byte);
218 if (XINT (byte) < 0 || XINT (byte) > 255)
219 error ("Invalid byte");
220 b = XINT (byte);
221 return make_string_from_bytes ((char *) &b, 1, 1);
224 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
225 doc: /* Return the first character in STRING. */)
226 (register Lisp_Object string)
228 register Lisp_Object val;
229 CHECK_STRING (string);
230 if (SCHARS (string))
232 if (STRING_MULTIBYTE (string))
233 XSETFASTINT (val, STRING_CHAR (SDATA (string)));
234 else
235 XSETFASTINT (val, SREF (string, 0));
237 else
238 XSETFASTINT (val, 0);
239 return val;
242 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
243 doc: /* Return value of point, as an integer.
244 Beginning of buffer is position (point-min). */)
245 (void)
247 Lisp_Object temp;
248 XSETFASTINT (temp, PT);
249 return temp;
252 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
253 doc: /* Return value of point, as a marker object. */)
254 (void)
256 return build_marker (current_buffer, PT, PT_BYTE);
259 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
260 doc: /* Set point to POSITION, a number or marker.
261 Beginning of buffer is position (point-min), end is (point-max).
263 The return value is POSITION. */)
264 (register Lisp_Object position)
266 if (MARKERP (position))
267 set_point_from_marker (position);
268 else if (INTEGERP (position))
269 SET_PT (clip_to_bounds (BEGV, XINT (position), ZV));
270 else
271 wrong_type_argument (Qinteger_or_marker_p, position);
272 return position;
276 /* Return the start or end position of the region.
277 BEGINNINGP means return the start.
278 If there is no region active, signal an error. */
280 static Lisp_Object
281 region_limit (bool beginningp)
283 Lisp_Object m;
285 if (!NILP (Vtransient_mark_mode)
286 && NILP (Vmark_even_if_inactive)
287 && NILP (BVAR (current_buffer, mark_active)))
288 xsignal0 (Qmark_inactive);
290 m = Fmarker_position (BVAR (current_buffer, mark));
291 if (NILP (m))
292 error ("The mark is not set now, so there is no region");
294 /* Clip to the current narrowing (bug#11770). */
295 return make_number ((PT < XFASTINT (m)) == beginningp
296 ? PT
297 : clip_to_bounds (BEGV, XFASTINT (m), ZV));
300 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
301 doc: /* Return the integer value of point or mark, whichever is smaller. */)
302 (void)
304 return region_limit (1);
307 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
308 doc: /* Return the integer value of point or mark, whichever is larger. */)
309 (void)
311 return region_limit (0);
314 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
315 doc: /* Return this buffer's mark, as a marker object.
316 Watch out! Moving this marker changes the mark position.
317 If you set the marker not to point anywhere, the buffer will have no mark. */)
318 (void)
320 return BVAR (current_buffer, mark);
324 /* Find all the overlays in the current buffer that touch position POS.
325 Return the number found, and store them in a vector in VEC
326 of length LEN. */
328 static ptrdiff_t
329 overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
331 Lisp_Object overlay, start, end;
332 struct Lisp_Overlay *tail;
333 ptrdiff_t startpos, endpos;
334 ptrdiff_t idx = 0;
336 for (tail = current_buffer->overlays_before; tail; tail = tail->next)
338 XSETMISC (overlay, tail);
340 end = OVERLAY_END (overlay);
341 endpos = OVERLAY_POSITION (end);
342 if (endpos < pos)
343 break;
344 start = OVERLAY_START (overlay);
345 startpos = OVERLAY_POSITION (start);
346 if (startpos <= pos)
348 if (idx < len)
349 vec[idx] = overlay;
350 /* Keep counting overlays even if we can't return them all. */
351 idx++;
355 for (tail = current_buffer->overlays_after; tail; tail = tail->next)
357 XSETMISC (overlay, tail);
359 start = OVERLAY_START (overlay);
360 startpos = OVERLAY_POSITION (start);
361 if (pos < startpos)
362 break;
363 end = OVERLAY_END (overlay);
364 endpos = OVERLAY_POSITION (end);
365 if (pos <= endpos)
367 if (idx < len)
368 vec[idx] = overlay;
369 idx++;
373 return idx;
376 DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
377 doc: /* Return the value of POSITION's property PROP, in OBJECT.
378 Almost identical to `get-char-property' except for the following difference:
379 Whereas `get-char-property' returns the property of the char at (i.e. right
380 after) POSITION, this pays attention to properties's stickiness and overlays's
381 advancement settings, in order to find the property of POSITION itself,
382 i.e. the property that a char would inherit if it were inserted
383 at POSITION. */)
384 (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
386 CHECK_NUMBER_COERCE_MARKER (position);
388 if (NILP (object))
389 XSETBUFFER (object, current_buffer);
390 else if (WINDOWP (object))
391 object = XWINDOW (object)->contents;
393 if (!BUFFERP (object))
394 /* pos-property only makes sense in buffers right now, since strings
395 have no overlays and no notion of insertion for which stickiness
396 could be obeyed. */
397 return Fget_text_property (position, prop, object);
398 else
400 EMACS_INT posn = XINT (position);
401 ptrdiff_t noverlays;
402 Lisp_Object *overlay_vec, tem;
403 struct buffer *obuf = current_buffer;
404 USE_SAFE_ALLOCA;
406 set_buffer_temp (XBUFFER (object));
408 /* First try with room for 40 overlays. */
409 Lisp_Object overlay_vecbuf[40];
410 noverlays = ARRAYELTS (overlay_vecbuf);
411 overlay_vec = overlay_vecbuf;
412 noverlays = overlays_around (posn, overlay_vec, noverlays);
414 /* If there are more than 40,
415 make enough space for all, and try again. */
416 if (ARRAYELTS (overlay_vecbuf) < noverlays)
418 SAFE_ALLOCA_LISP (overlay_vec, noverlays);
419 noverlays = overlays_around (posn, overlay_vec, noverlays);
421 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
423 set_buffer_temp (obuf);
425 /* Now check the overlays in order of decreasing priority. */
426 while (--noverlays >= 0)
428 Lisp_Object ol = overlay_vec[noverlays];
429 tem = Foverlay_get (ol, prop);
430 if (!NILP (tem))
432 /* Check the overlay is indeed active at point. */
433 Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
434 if ((OVERLAY_POSITION (start) == posn
435 && XMARKER (start)->insertion_type == 1)
436 || (OVERLAY_POSITION (finish) == posn
437 && XMARKER (finish)->insertion_type == 0))
438 ; /* The overlay will not cover a char inserted at point. */
439 else
441 SAFE_FREE ();
442 return tem;
446 SAFE_FREE ();
448 { /* Now check the text properties. */
449 int stickiness = text_property_stickiness (prop, position, object);
450 if (stickiness > 0)
451 return Fget_text_property (position, prop, object);
452 else if (stickiness < 0
453 && XINT (position) > BUF_BEGV (XBUFFER (object)))
454 return Fget_text_property (make_number (XINT (position) - 1),
455 prop, object);
456 else
457 return Qnil;
462 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
463 the value of point is used instead. If BEG or END is null,
464 means don't store the beginning or end of the field.
466 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
467 results; they do not effect boundary behavior.
469 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
470 position of a field, then the beginning of the previous field is
471 returned instead of the beginning of POS's field (since the end of a
472 field is actually also the beginning of the next input field, this
473 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
474 non-nil case, if two fields are separated by a field with the special
475 value `boundary', and POS lies within it, then the two separated
476 fields are considered to be adjacent, and POS between them, when
477 finding the beginning and ending of the "merged" field.
479 Either BEG or END may be 0, in which case the corresponding value
480 is not stored. */
482 static void
483 find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
484 Lisp_Object beg_limit,
485 ptrdiff_t *beg, Lisp_Object end_limit, ptrdiff_t *end)
487 /* Fields right before and after the point. */
488 Lisp_Object before_field, after_field;
489 /* True if POS counts as the start of a field. */
490 bool at_field_start = 0;
491 /* True if POS counts as the end of a field. */
492 bool at_field_end = 0;
494 if (NILP (pos))
495 XSETFASTINT (pos, PT);
496 else
497 CHECK_NUMBER_COERCE_MARKER (pos);
499 after_field
500 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
501 before_field
502 = (XFASTINT (pos) > BEGV
503 ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
504 Qfield, Qnil, NULL)
505 /* Using nil here would be a more obvious choice, but it would
506 fail when the buffer starts with a non-sticky field. */
507 : after_field);
509 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
510 and POS is at beginning of a field, which can also be interpreted
511 as the end of the previous field. Note that the case where if
512 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
513 more natural one; then we avoid treating the beginning of a field
514 specially. */
515 if (NILP (merge_at_boundary))
517 Lisp_Object field = Fget_pos_property (pos, Qfield, Qnil);
518 if (!EQ (field, after_field))
519 at_field_end = 1;
520 if (!EQ (field, before_field))
521 at_field_start = 1;
522 if (NILP (field) && at_field_start && at_field_end)
523 /* If an inserted char would have a nil field while the surrounding
524 text is non-nil, we're probably not looking at a
525 zero-length field, but instead at a non-nil field that's
526 not intended for editing (such as comint's prompts). */
527 at_field_end = at_field_start = 0;
530 /* Note about special `boundary' fields:
532 Consider the case where the point (`.') is between the fields `x' and `y':
534 xxxx.yyyy
536 In this situation, if merge_at_boundary is non-nil, consider the
537 `x' and `y' fields as forming one big merged field, and so the end
538 of the field is the end of `y'.
540 However, if `x' and `y' are separated by a special `boundary' field
541 (a field with a `field' char-property of 'boundary), then ignore
542 this special field when merging adjacent fields. Here's the same
543 situation, but with a `boundary' field between the `x' and `y' fields:
545 xxx.BBBByyyy
547 Here, if point is at the end of `x', the beginning of `y', or
548 anywhere in-between (within the `boundary' field), merge all
549 three fields and consider the beginning as being the beginning of
550 the `x' field, and the end as being the end of the `y' field. */
552 if (beg)
554 if (at_field_start)
555 /* POS is at the edge of a field, and we should consider it as
556 the beginning of the following field. */
557 *beg = XFASTINT (pos);
558 else
559 /* Find the previous field boundary. */
561 Lisp_Object p = pos;
562 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
563 /* Skip a `boundary' field. */
564 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
565 beg_limit);
567 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
568 beg_limit);
569 *beg = NILP (p) ? BEGV : XFASTINT (p);
573 if (end)
575 if (at_field_end)
576 /* POS is at the edge of a field, and we should consider it as
577 the end of the previous field. */
578 *end = XFASTINT (pos);
579 else
580 /* Find the next field boundary. */
582 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
583 /* Skip a `boundary' field. */
584 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
585 end_limit);
587 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
588 end_limit);
589 *end = NILP (pos) ? ZV : XFASTINT (pos);
595 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
596 doc: /* Delete the field surrounding POS.
597 A field is a region of text with the same `field' property.
598 If POS is nil, the value of point is used for POS. */)
599 (Lisp_Object pos)
601 ptrdiff_t beg, end;
602 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
603 if (beg != end)
604 del_range (beg, end);
605 return Qnil;
608 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
609 doc: /* Return the contents of the field surrounding POS as a string.
610 A field is a region of text with the same `field' property.
611 If POS is nil, the value of point is used for POS. */)
612 (Lisp_Object pos)
614 ptrdiff_t beg, end;
615 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
616 return make_buffer_string (beg, end, 1);
619 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
620 doc: /* Return the contents of the field around POS, without text properties.
621 A field is a region of text with the same `field' property.
622 If POS is nil, the value of point is used for POS. */)
623 (Lisp_Object pos)
625 ptrdiff_t beg, end;
626 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
627 return make_buffer_string (beg, end, 0);
630 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
631 doc: /* Return the beginning of the field surrounding POS.
632 A field is a region of text with the same `field' property.
633 If POS is nil, the value of point is used for POS.
634 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
635 field, then the beginning of the *previous* field is returned.
636 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
637 is before LIMIT, then LIMIT will be returned instead. */)
638 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
640 ptrdiff_t beg;
641 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
642 return make_number (beg);
645 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
646 doc: /* Return the end of the field surrounding POS.
647 A field is a region of text with the same `field' property.
648 If POS is nil, the value of point is used for POS.
649 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
650 then the end of the *following* field is returned.
651 If LIMIT is non-nil, it is a buffer position; if the end of the field
652 is after LIMIT, then LIMIT will be returned instead. */)
653 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
655 ptrdiff_t end;
656 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
657 return make_number (end);
660 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
661 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
662 A field is a region of text with the same `field' property.
664 If NEW-POS is nil, then use the current point instead, and move point
665 to the resulting constrained position, in addition to returning that
666 position.
668 If OLD-POS is at the boundary of two fields, then the allowable
669 positions for NEW-POS depends on the value of the optional argument
670 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
671 constrained to the field that has the same `field' char-property
672 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
673 is non-nil, NEW-POS is constrained to the union of the two adjacent
674 fields. Additionally, if two fields are separated by another field with
675 the special value `boundary', then any point within this special field is
676 also considered to be `on the boundary'.
678 If the optional argument ONLY-IN-LINE is non-nil and constraining
679 NEW-POS would move it to a different line, NEW-POS is returned
680 unconstrained. This is useful for commands that move by line, like
681 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
682 only in the case where they can still move to the right line.
684 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
685 a non-nil property of that name, then any field boundaries are ignored.
687 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
688 (Lisp_Object new_pos, Lisp_Object old_pos, Lisp_Object escape_from_edge,
689 Lisp_Object only_in_line, Lisp_Object inhibit_capture_property)
691 /* If non-zero, then the original point, before re-positioning. */
692 ptrdiff_t orig_point = 0;
693 bool fwd;
694 Lisp_Object prev_old, prev_new;
696 if (NILP (new_pos))
697 /* Use the current point, and afterwards, set it. */
699 orig_point = PT;
700 XSETFASTINT (new_pos, PT);
703 CHECK_NUMBER_COERCE_MARKER (new_pos);
704 CHECK_NUMBER_COERCE_MARKER (old_pos);
706 fwd = (XINT (new_pos) > XINT (old_pos));
708 prev_old = make_number (XINT (old_pos) - 1);
709 prev_new = make_number (XINT (new_pos) - 1);
711 if (NILP (Vinhibit_field_text_motion)
712 && !EQ (new_pos, old_pos)
713 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
714 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
715 /* To recognize field boundaries, we must also look at the
716 previous positions; we could use `Fget_pos_property'
717 instead, but in itself that would fail inside non-sticky
718 fields (like comint prompts). */
719 || (XFASTINT (new_pos) > BEGV
720 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
721 || (XFASTINT (old_pos) > BEGV
722 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
723 && (NILP (inhibit_capture_property)
724 /* Field boundaries are again a problem; but now we must
725 decide the case exactly, so we need to call
726 `get_pos_property' as well. */
727 || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil))
728 && (XFASTINT (old_pos) <= BEGV
729 || NILP (Fget_char_property
730 (old_pos, inhibit_capture_property, Qnil))
731 || NILP (Fget_char_property
732 (prev_old, inhibit_capture_property, Qnil))))))
733 /* It is possible that NEW_POS is not within the same field as
734 OLD_POS; try to move NEW_POS so that it is. */
736 ptrdiff_t shortage;
737 Lisp_Object field_bound;
739 if (fwd)
740 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
741 else
742 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
744 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
745 other side of NEW_POS, which would mean that NEW_POS is
746 already acceptable, and it's not necessary to constrain it
747 to FIELD_BOUND. */
748 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
749 /* NEW_POS should be constrained, but only if either
750 ONLY_IN_LINE is nil (in which case any constraint is OK),
751 or NEW_POS and FIELD_BOUND are on the same line (in which
752 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
753 && (NILP (only_in_line)
754 /* This is the ONLY_IN_LINE case, check that NEW_POS and
755 FIELD_BOUND are on the same line by seeing whether
756 there's an intervening newline or not. */
757 || (find_newline (XFASTINT (new_pos), -1,
758 XFASTINT (field_bound), -1,
759 fwd ? -1 : 1, &shortage, NULL, 1),
760 shortage != 0)))
761 /* Constrain NEW_POS to FIELD_BOUND. */
762 new_pos = field_bound;
764 if (orig_point && XFASTINT (new_pos) != orig_point)
765 /* The NEW_POS argument was originally nil, so automatically set PT. */
766 SET_PT (XFASTINT (new_pos));
769 return new_pos;
773 DEFUN ("line-beginning-position",
774 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
775 doc: /* Return the character position of the first character on the current line.
776 With optional argument N, scan forward N - 1 lines first.
777 If the scan reaches the end of the buffer, return that position.
779 This function ignores text display directionality; it returns the
780 position of the first character in logical order, i.e. the smallest
781 character position on the line.
783 This function constrains the returned position to the current field
784 unless that position would be on a different line than the original,
785 unconstrained result. If N is nil or 1, and a front-sticky field
786 starts at point, the scan stops as soon as it starts. To ignore field
787 boundaries, bind `inhibit-field-text-motion' to t.
789 This function does not move point. */)
790 (Lisp_Object n)
792 ptrdiff_t charpos, bytepos;
794 if (NILP (n))
795 XSETFASTINT (n, 1);
796 else
797 CHECK_NUMBER (n);
799 scan_newline_from_point (XINT (n) - 1, &charpos, &bytepos);
801 /* Return END constrained to the current input field. */
802 return Fconstrain_to_field (make_number (charpos), make_number (PT),
803 XINT (n) != 1 ? Qt : Qnil,
804 Qt, Qnil);
807 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
808 doc: /* Return the character position of the last character on the current line.
809 With argument N not nil or 1, move forward N - 1 lines first.
810 If scan reaches end of buffer, return that position.
812 This function ignores text display directionality; it returns the
813 position of the last character in logical order, i.e. the largest
814 character position on the line.
816 This function constrains the returned position to the current field
817 unless that would be on a different line than the original,
818 unconstrained result. If N is nil or 1, and a rear-sticky field ends
819 at point, 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. */)
823 (Lisp_Object n)
825 ptrdiff_t clipped_n;
826 ptrdiff_t end_pos;
827 ptrdiff_t orig = PT;
829 if (NILP (n))
830 XSETFASTINT (n, 1);
831 else
832 CHECK_NUMBER (n);
834 clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX);
835 end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0),
836 NULL);
838 /* Return END_POS constrained to the current input field. */
839 return Fconstrain_to_field (make_number (end_pos), make_number (orig),
840 Qnil, Qt, Qnil);
843 /* Save current buffer state for `save-excursion' special form.
844 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
845 offload some work from GC. */
847 Lisp_Object
848 save_excursion_save (void)
850 return make_save_obj_obj_obj_obj
851 (Fpoint_marker (),
852 Qnil,
853 /* Selected window if current buffer is shown in it, nil otherwise. */
854 (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
855 ? selected_window : Qnil),
856 Qnil);
859 /* Restore saved buffer before leaving `save-excursion' special form. */
861 void
862 save_excursion_restore (Lisp_Object info)
864 Lisp_Object tem, tem1;
865 struct gcpro gcpro1;
867 tem = Fmarker_buffer (XSAVE_OBJECT (info, 0));
868 /* If we're unwinding to top level, saved buffer may be deleted. This
869 means that all of its markers are unchained and so tem is nil. */
870 if (NILP (tem))
871 goto out;
873 GCPRO1 (info);
875 Fset_buffer (tem);
877 /* Point marker. */
878 tem = XSAVE_OBJECT (info, 0);
879 Fgoto_char (tem);
880 unchain_marker (XMARKER (tem));
882 /* If buffer was visible in a window, and a different window was
883 selected, and the old selected window is still showing this
884 buffer, restore point in that window. */
885 tem = XSAVE_OBJECT (info, 2);
886 if (WINDOWP (tem)
887 && !EQ (tem, selected_window)
888 && (tem1 = XWINDOW (tem)->contents,
889 (/* Window is live... */
890 BUFFERP (tem1)
891 /* ...and it shows the current buffer. */
892 && XBUFFER (tem1) == current_buffer)))
893 Fset_window_point (tem, make_number (PT));
895 UNGCPRO;
897 out:
899 free_misc (info);
902 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
903 doc: /* Save point, and current buffer; execute BODY; restore those things.
904 Executes BODY just like `progn'.
905 The values of point and the current buffer are restored
906 even in case of abnormal exit (throw or error).
908 If you only want to save the current buffer but not point,
909 then just use `save-current-buffer', or even `with-current-buffer'.
911 Before Emacs 25.1, `save-excursion' used to save the mark state.
912 To save the marker state as well as the point and buffer, use
913 `save-mark-and-excursion'.
915 usage: (save-excursion &rest BODY) */)
916 (Lisp_Object args)
918 register Lisp_Object val;
919 ptrdiff_t count = SPECPDL_INDEX ();
921 record_unwind_protect (save_excursion_restore, save_excursion_save ());
923 val = Fprogn (args);
924 return unbind_to (count, val);
927 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
928 doc: /* Record which buffer is current; execute BODY; make that buffer current.
929 BODY is executed just like `progn'.
930 usage: (save-current-buffer &rest BODY) */)
931 (Lisp_Object args)
933 ptrdiff_t count = SPECPDL_INDEX ();
935 record_unwind_current_buffer ();
936 return unbind_to (count, Fprogn (args));
939 DEFUN ("buffer-size", Fbuffer_size, Sbuffer_size, 0, 1, 0,
940 doc: /* Return the number of characters in the current buffer.
941 If BUFFER, return the number of characters in that buffer instead. */)
942 (Lisp_Object buffer)
944 if (NILP (buffer))
945 return make_number (Z - BEG);
946 else
948 CHECK_BUFFER (buffer);
949 return make_number (BUF_Z (XBUFFER (buffer))
950 - BUF_BEG (XBUFFER (buffer)));
954 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
955 doc: /* Return the minimum permissible value of point in the current buffer.
956 This is 1, unless narrowing (a buffer restriction) is in effect. */)
957 (void)
959 Lisp_Object temp;
960 XSETFASTINT (temp, BEGV);
961 return temp;
964 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
965 doc: /* Return a marker to the minimum permissible value of point in this buffer.
966 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
967 (void)
969 return build_marker (current_buffer, BEGV, BEGV_BYTE);
972 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
973 doc: /* Return the maximum permissible value of point in the current buffer.
974 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
975 is in effect, in which case it is less. */)
976 (void)
978 Lisp_Object temp;
979 XSETFASTINT (temp, ZV);
980 return temp;
983 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
984 doc: /* Return a marker to the maximum permissible value of point in this buffer.
985 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
986 is in effect, in which case it is less. */)
987 (void)
989 return build_marker (current_buffer, ZV, ZV_BYTE);
992 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
993 doc: /* Return the position of the gap, in the current buffer.
994 See also `gap-size'. */)
995 (void)
997 Lisp_Object temp;
998 XSETFASTINT (temp, GPT);
999 return temp;
1002 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
1003 doc: /* Return the size of the current buffer's gap.
1004 See also `gap-position'. */)
1005 (void)
1007 Lisp_Object temp;
1008 XSETFASTINT (temp, GAP_SIZE);
1009 return temp;
1012 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
1013 doc: /* Return the byte position for character position POSITION.
1014 If POSITION is out of range, the value is nil. */)
1015 (Lisp_Object position)
1017 CHECK_NUMBER_COERCE_MARKER (position);
1018 if (XINT (position) < BEG || XINT (position) > Z)
1019 return Qnil;
1020 return make_number (CHAR_TO_BYTE (XINT (position)));
1023 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
1024 doc: /* Return the character position for byte position BYTEPOS.
1025 If BYTEPOS is out of range, the value is nil. */)
1026 (Lisp_Object bytepos)
1028 CHECK_NUMBER (bytepos);
1029 if (XINT (bytepos) < BEG_BYTE || XINT (bytepos) > Z_BYTE)
1030 return Qnil;
1031 return make_number (BYTE_TO_CHAR (XINT (bytepos)));
1034 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
1035 doc: /* Return the character following point, as a number.
1036 At the end of the buffer or accessible region, return 0. */)
1037 (void)
1039 Lisp_Object temp;
1040 if (PT >= ZV)
1041 XSETFASTINT (temp, 0);
1042 else
1043 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
1044 return temp;
1047 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
1048 doc: /* Return the character preceding point, as a number.
1049 At the beginning of the buffer or accessible region, return 0. */)
1050 (void)
1052 Lisp_Object temp;
1053 if (PT <= BEGV)
1054 XSETFASTINT (temp, 0);
1055 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1057 ptrdiff_t pos = PT_BYTE;
1058 DEC_POS (pos);
1059 XSETFASTINT (temp, FETCH_CHAR (pos));
1061 else
1062 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
1063 return temp;
1066 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
1067 doc: /* Return t if point is at the beginning of the buffer.
1068 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1069 (void)
1071 if (PT == BEGV)
1072 return Qt;
1073 return Qnil;
1076 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
1077 doc: /* Return t if point is at the end of the buffer.
1078 If the buffer is narrowed, this means the end of the narrowed part. */)
1079 (void)
1081 if (PT == ZV)
1082 return Qt;
1083 return Qnil;
1086 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
1087 doc: /* Return t if point is at the beginning of a line. */)
1088 (void)
1090 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
1091 return Qt;
1092 return Qnil;
1095 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
1096 doc: /* Return t if point is at the end of a line.
1097 `End of a line' includes point being at the end of the buffer. */)
1098 (void)
1100 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
1101 return Qt;
1102 return Qnil;
1105 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
1106 doc: /* Return character in current buffer at position POS.
1107 POS is an integer or a marker and defaults to point.
1108 If POS is out of range, the value is nil. */)
1109 (Lisp_Object pos)
1111 register ptrdiff_t pos_byte;
1113 if (NILP (pos))
1115 pos_byte = PT_BYTE;
1116 XSETFASTINT (pos, PT);
1119 if (MARKERP (pos))
1121 pos_byte = marker_byte_position (pos);
1122 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1123 return Qnil;
1125 else
1127 CHECK_NUMBER_COERCE_MARKER (pos);
1128 if (XINT (pos) < BEGV || XINT (pos) >= ZV)
1129 return Qnil;
1131 pos_byte = CHAR_TO_BYTE (XINT (pos));
1134 return make_number (FETCH_CHAR (pos_byte));
1137 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
1138 doc: /* Return character in current buffer preceding position POS.
1139 POS is an integer or a marker and defaults to point.
1140 If POS is out of range, the value is nil. */)
1141 (Lisp_Object pos)
1143 register Lisp_Object val;
1144 register ptrdiff_t pos_byte;
1146 if (NILP (pos))
1148 pos_byte = PT_BYTE;
1149 XSETFASTINT (pos, PT);
1152 if (MARKERP (pos))
1154 pos_byte = marker_byte_position (pos);
1156 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
1157 return Qnil;
1159 else
1161 CHECK_NUMBER_COERCE_MARKER (pos);
1163 if (XINT (pos) <= BEGV || XINT (pos) > ZV)
1164 return Qnil;
1166 pos_byte = CHAR_TO_BYTE (XINT (pos));
1169 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1171 DEC_POS (pos_byte);
1172 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1174 else
1176 pos_byte--;
1177 XSETFASTINT (val, FETCH_BYTE (pos_byte));
1179 return val;
1182 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
1183 doc: /* Return the name under which the user logged in, as a string.
1184 This is based on the effective uid, not the real uid.
1185 Also, if the environment variables LOGNAME or USER are set,
1186 that determines the value of this function.
1188 If optional argument UID is an integer or a float, return the login name
1189 of the user with that uid, or nil if there is no such user. */)
1190 (Lisp_Object uid)
1192 struct passwd *pw;
1193 uid_t id;
1195 /* Set up the user name info if we didn't do it before.
1196 (That can happen if Emacs is dumpable
1197 but you decide to run `temacs -l loadup' and not dump. */
1198 if (NILP (Vuser_login_name))
1199 init_editfns ();
1201 if (NILP (uid))
1202 return Vuser_login_name;
1204 CONS_TO_INTEGER (uid, uid_t, id);
1205 block_input ();
1206 pw = getpwuid (id);
1207 unblock_input ();
1208 return (pw ? build_string (pw->pw_name) : Qnil);
1211 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
1212 0, 0, 0,
1213 doc: /* Return the name of the user's real uid, as a string.
1214 This ignores the environment variables LOGNAME and USER, so it differs from
1215 `user-login-name' when running under `su'. */)
1216 (void)
1218 /* Set up the user name info if we didn't do it before.
1219 (That can happen if Emacs is dumpable
1220 but you decide to run `temacs -l loadup' and not dump. */
1221 if (NILP (Vuser_login_name))
1222 init_editfns ();
1223 return Vuser_real_login_name;
1226 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1227 doc: /* Return the effective uid of Emacs.
1228 Value is an integer or a float, depending on the value. */)
1229 (void)
1231 uid_t euid = geteuid ();
1232 return make_fixnum_or_float (euid);
1235 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1236 doc: /* Return the real uid of Emacs.
1237 Value is an integer or a float, depending on the value. */)
1238 (void)
1240 uid_t uid = getuid ();
1241 return make_fixnum_or_float (uid);
1244 DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
1245 doc: /* Return the effective gid of Emacs.
1246 Value is an integer or a float, depending on the value. */)
1247 (void)
1249 gid_t egid = getegid ();
1250 return make_fixnum_or_float (egid);
1253 DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
1254 doc: /* Return the real gid of Emacs.
1255 Value is an integer or a float, depending on the value. */)
1256 (void)
1258 gid_t gid = getgid ();
1259 return make_fixnum_or_float (gid);
1262 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1263 doc: /* Return the full name of the user logged in, as a string.
1264 If the full name corresponding to Emacs's userid is not known,
1265 return "unknown".
1267 If optional argument UID is an integer or float, return the full name
1268 of the user with that uid, or nil if there is no such user.
1269 If UID is a string, return the full name of the user with that login
1270 name, or nil if there is no such user. */)
1271 (Lisp_Object uid)
1273 struct passwd *pw;
1274 register char *p, *q;
1275 Lisp_Object full;
1277 if (NILP (uid))
1278 return Vuser_full_name;
1279 else if (NUMBERP (uid))
1281 uid_t u;
1282 CONS_TO_INTEGER (uid, uid_t, u);
1283 block_input ();
1284 pw = getpwuid (u);
1285 unblock_input ();
1287 else if (STRINGP (uid))
1289 block_input ();
1290 pw = getpwnam (SSDATA (uid));
1291 unblock_input ();
1293 else
1294 error ("Invalid UID specification");
1296 if (!pw)
1297 return Qnil;
1299 p = USER_FULL_NAME;
1300 /* Chop off everything after the first comma. */
1301 q = strchr (p, ',');
1302 full = make_string (p, q ? q - p : strlen (p));
1304 #ifdef AMPERSAND_FULL_NAME
1305 p = SSDATA (full);
1306 q = strchr (p, '&');
1307 /* Substitute the login name for the &, upcasing the first character. */
1308 if (q)
1310 Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid));
1311 USE_SAFE_ALLOCA;
1312 char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
1313 memcpy (r, p, q - p);
1314 char *s = lispstpcpy (&r[q - p], login);
1315 r[q - p] = upcase ((unsigned char) r[q - p]);
1316 strcpy (s, q + 1);
1317 full = build_string (r);
1318 SAFE_FREE ();
1320 #endif /* AMPERSAND_FULL_NAME */
1322 return full;
1325 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1326 doc: /* Return the host name of the machine you are running on, as a string. */)
1327 (void)
1329 if (EQ (Vsystem_name, cached_system_name))
1330 init_and_cache_system_name ();
1331 return Vsystem_name;
1334 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1335 doc: /* Return the process ID of Emacs, as a number. */)
1336 (void)
1338 pid_t pid = getpid ();
1339 return make_fixnum_or_float (pid);
1344 #ifndef TIME_T_MIN
1345 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1346 #endif
1347 #ifndef TIME_T_MAX
1348 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1349 #endif
1351 /* Report that a time value is out of range for Emacs. */
1352 void
1353 time_overflow (void)
1355 error ("Specified time is not representable");
1358 static void
1359 invalid_time (void)
1361 error ("Invalid time specification");
1364 /* Check a return value compatible with that of decode_time_components. */
1365 static void
1366 check_time_validity (int validity)
1368 if (validity <= 0)
1370 if (validity < 0)
1371 time_overflow ();
1372 else
1373 invalid_time ();
1377 /* A substitute for mktime_z on platforms that lack it. It's not
1378 thread-safe, but should be good enough for Emacs in typical use. */
1379 #ifndef HAVE_TZALLOC
1380 static time_t
1381 mktime_z (timezone_t tz, struct tm *tm)
1383 char *oldtz = getenv ("TZ");
1384 USE_SAFE_ALLOCA;
1385 if (oldtz)
1387 size_t oldtzsize = strlen (oldtz) + 1;
1388 char *oldtzcopy = SAFE_ALLOCA (oldtzsize);
1389 oldtz = strcpy (oldtzcopy, oldtz);
1391 block_input ();
1392 set_time_zone_rule (tz);
1393 time_t t = mktime (tm);
1394 set_time_zone_rule (oldtz);
1395 unblock_input ();
1396 SAFE_FREE ();
1397 return t;
1399 #endif
1401 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1402 static EMACS_INT
1403 hi_time (time_t t)
1405 time_t hi = t >> LO_TIME_BITS;
1407 /* Check for overflow, helping the compiler for common cases where
1408 no runtime check is needed, and taking care not to convert
1409 negative numbers to unsigned before comparing them. */
1410 if (! ((! TYPE_SIGNED (time_t)
1411 || MOST_NEGATIVE_FIXNUM <= TIME_T_MIN >> LO_TIME_BITS
1412 || MOST_NEGATIVE_FIXNUM <= hi)
1413 && (TIME_T_MAX >> LO_TIME_BITS <= MOST_POSITIVE_FIXNUM
1414 || hi <= MOST_POSITIVE_FIXNUM)))
1415 time_overflow ();
1417 return hi;
1420 /* Return the bottom bits of the time T. */
1421 static int
1422 lo_time (time_t t)
1424 return t & ((1 << LO_TIME_BITS) - 1);
1427 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1428 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1429 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1430 HIGH has the most significant bits of the seconds, while LOW has the
1431 least significant 16 bits. USEC and PSEC are the microsecond and
1432 picosecond counts. */)
1433 (void)
1435 return make_lisp_time (current_timespec ());
1438 static struct lisp_time
1439 time_add (struct lisp_time ta, struct lisp_time tb)
1441 EMACS_INT hi = ta.hi + tb.hi;
1442 int lo = ta.lo + tb.lo;
1443 int us = ta.us + tb.us;
1444 int ps = ta.ps + tb.ps;
1445 us += (1000000 <= ps);
1446 ps -= (1000000 <= ps) * 1000000;
1447 lo += (1000000 <= us);
1448 us -= (1000000 <= us) * 1000000;
1449 hi += (1 << LO_TIME_BITS <= lo);
1450 lo -= (1 << LO_TIME_BITS <= lo) << LO_TIME_BITS;
1451 return (struct lisp_time) { hi, lo, us, ps };
1454 static struct lisp_time
1455 time_subtract (struct lisp_time ta, struct lisp_time tb)
1457 EMACS_INT hi = ta.hi - tb.hi;
1458 int lo = ta.lo - tb.lo;
1459 int us = ta.us - tb.us;
1460 int ps = ta.ps - tb.ps;
1461 us -= (ps < 0);
1462 ps += (ps < 0) * 1000000;
1463 lo -= (us < 0);
1464 us += (us < 0) * 1000000;
1465 hi -= (lo < 0);
1466 lo += (lo < 0) << LO_TIME_BITS;
1467 return (struct lisp_time) { hi, lo, us, ps };
1470 static Lisp_Object
1471 time_arith (Lisp_Object a, Lisp_Object b,
1472 struct lisp_time (*op) (struct lisp_time, struct lisp_time))
1474 int alen, blen;
1475 struct lisp_time ta = lisp_time_struct (a, &alen);
1476 struct lisp_time tb = lisp_time_struct (b, &blen);
1477 struct lisp_time t = op (ta, tb);
1478 if (! (MOST_NEGATIVE_FIXNUM <= t.hi && t.hi <= MOST_POSITIVE_FIXNUM))
1479 time_overflow ();
1480 Lisp_Object val = Qnil;
1482 switch (max (alen, blen))
1484 default:
1485 val = Fcons (make_number (t.ps), val);
1486 /* Fall through. */
1487 case 3:
1488 val = Fcons (make_number (t.us), val);
1489 /* Fall through. */
1490 case 2:
1491 val = Fcons (make_number (t.lo), val);
1492 val = Fcons (make_number (t.hi), val);
1493 break;
1496 return val;
1499 DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
1500 doc: /* Return the sum of two time values A and B, as a time value. */)
1501 (Lisp_Object a, Lisp_Object b)
1503 return time_arith (a, b, time_add);
1506 DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
1507 doc: /* Return the difference between two time values A and B, as a time value. */)
1508 (Lisp_Object a, Lisp_Object b)
1510 return time_arith (a, b, time_subtract);
1513 DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
1514 doc: /* Return non-nil if time value T1 is earlier than time value T2. */)
1515 (Lisp_Object t1, Lisp_Object t2)
1517 int t1len, t2len;
1518 struct lisp_time a = lisp_time_struct (t1, &t1len);
1519 struct lisp_time b = lisp_time_struct (t2, &t2len);
1520 return ((a.hi != b.hi ? a.hi < b.hi
1521 : a.lo != b.lo ? a.lo < b.lo
1522 : a.us != b.us ? a.us < b.us
1523 : a.ps < b.ps)
1524 ? Qt : Qnil);
1528 DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
1529 0, 0, 0,
1530 doc: /* Return the current run time used by Emacs.
1531 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1532 style as (current-time).
1534 On systems that can't determine the run time, `get-internal-run-time'
1535 does the same thing as `current-time'. */)
1536 (void)
1538 #ifdef HAVE_GETRUSAGE
1539 struct rusage usage;
1540 time_t secs;
1541 int usecs;
1543 if (getrusage (RUSAGE_SELF, &usage) < 0)
1544 /* This shouldn't happen. What action is appropriate? */
1545 xsignal0 (Qerror);
1547 /* Sum up user time and system time. */
1548 secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
1549 usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
1550 if (usecs >= 1000000)
1552 usecs -= 1000000;
1553 secs++;
1555 return make_lisp_time (make_timespec (secs, usecs * 1000));
1556 #else /* ! HAVE_GETRUSAGE */
1557 #ifdef WINDOWSNT
1558 return w32_get_internal_run_time ();
1559 #else /* ! WINDOWSNT */
1560 return Fcurrent_time ();
1561 #endif /* WINDOWSNT */
1562 #endif /* HAVE_GETRUSAGE */
1566 /* Make a Lisp list that represents the Emacs time T. T may be an
1567 invalid time, with a slightly negative tv_nsec value such as
1568 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1569 correspondingly negative picosecond count. */
1570 Lisp_Object
1571 make_lisp_time (struct timespec t)
1573 time_t s = t.tv_sec;
1574 int ns = t.tv_nsec;
1575 return list4i (hi_time (s), lo_time (s), ns / 1000, ns % 1000 * 1000);
1578 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1579 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1580 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1581 if successful, 0 if unsuccessful. */
1582 static int
1583 disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh,
1584 Lisp_Object *plow, Lisp_Object *pusec,
1585 Lisp_Object *ppsec)
1587 Lisp_Object high = make_number (0);
1588 Lisp_Object low = specified_time;
1589 Lisp_Object usec = make_number (0);
1590 Lisp_Object psec = make_number (0);
1591 int len = 4;
1593 if (CONSP (specified_time))
1595 high = XCAR (specified_time);
1596 low = XCDR (specified_time);
1597 if (CONSP (low))
1599 Lisp_Object low_tail = XCDR (low);
1600 low = XCAR (low);
1601 if (CONSP (low_tail))
1603 usec = XCAR (low_tail);
1604 low_tail = XCDR (low_tail);
1605 if (CONSP (low_tail))
1606 psec = XCAR (low_tail);
1607 else
1608 len = 3;
1610 else if (!NILP (low_tail))
1612 usec = low_tail;
1613 len = 3;
1615 else
1616 len = 2;
1618 else
1619 len = 2;
1621 /* When combining components, require LOW to be an integer,
1622 as otherwise it would be a pain to add up times. */
1623 if (! INTEGERP (low))
1624 return 0;
1626 else if (INTEGERP (specified_time))
1627 len = 2;
1629 *phigh = high;
1630 *plow = low;
1631 *pusec = usec;
1632 *ppsec = psec;
1633 return len;
1636 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1637 Return true if T is in range, false otherwise. */
1638 static bool
1639 decode_float_time (double t, struct lisp_time *result)
1641 double lo_multiplier = 1 << LO_TIME_BITS;
1642 double emacs_time_min = MOST_NEGATIVE_FIXNUM * lo_multiplier;
1643 if (! (emacs_time_min <= t && t < -emacs_time_min))
1644 return false;
1646 double small_t = t / lo_multiplier;
1647 EMACS_INT hi = small_t;
1648 double t_sans_hi = t - hi * lo_multiplier;
1649 int lo = t_sans_hi;
1650 long double fracps = (t_sans_hi - lo) * 1e12L;
1651 #ifdef INT_FAST64_MAX
1652 int_fast64_t ifracps = fracps;
1653 int us = ifracps / 1000000;
1654 int ps = ifracps % 1000000;
1655 #else
1656 int us = fracps / 1e6L;
1657 int ps = fracps - us * 1e6L;
1658 #endif
1659 us -= (ps < 0);
1660 ps += (ps < 0) * 1000000;
1661 lo -= (us < 0);
1662 us += (us < 0) * 1000000;
1663 hi -= (lo < 0);
1664 lo += (lo < 0) << LO_TIME_BITS;
1665 result->hi = hi;
1666 result->lo = lo;
1667 result->us = us;
1668 result->ps = ps;
1669 return true;
1672 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1673 list, generate the corresponding time value.
1674 If LOW is floating point, the other components should be zero.
1676 If RESULT is not null, store into *RESULT the converted time.
1677 If *DRESULT is not null, store into *DRESULT the number of
1678 seconds since the start of the POSIX Epoch.
1680 Return 1 if successful, 0 if the components are of the
1681 wrong type, and -1 if the time is out of range. */
1683 decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec,
1684 Lisp_Object psec,
1685 struct lisp_time *result, double *dresult)
1687 EMACS_INT hi, lo, us, ps;
1688 if (! (INTEGERP (high)
1689 && INTEGERP (usec) && INTEGERP (psec)))
1690 return 0;
1691 if (! INTEGERP (low))
1693 if (FLOATP (low))
1695 double t = XFLOAT_DATA (low);
1696 if (result && ! decode_float_time (t, result))
1697 return -1;
1698 if (dresult)
1699 *dresult = t;
1700 return 1;
1702 else if (NILP (low))
1704 struct timespec now = current_timespec ();
1705 if (result)
1707 result->hi = hi_time (now.tv_sec);
1708 result->lo = lo_time (now.tv_sec);
1709 result->us = now.tv_nsec / 1000;
1710 result->ps = now.tv_nsec % 1000 * 1000;
1712 if (dresult)
1713 *dresult = now.tv_sec + now.tv_nsec / 1e9;
1714 return 1;
1716 else
1717 return 0;
1720 hi = XINT (high);
1721 lo = XINT (low);
1722 us = XINT (usec);
1723 ps = XINT (psec);
1725 /* Normalize out-of-range lower-order components by carrying
1726 each overflow into the next higher-order component. */
1727 us += ps / 1000000 - (ps % 1000000 < 0);
1728 lo += us / 1000000 - (us % 1000000 < 0);
1729 hi += lo >> LO_TIME_BITS;
1730 ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
1731 us = us % 1000000 + 1000000 * (us % 1000000 < 0);
1732 lo &= (1 << LO_TIME_BITS) - 1;
1734 if (result)
1736 if (! (MOST_NEGATIVE_FIXNUM <= hi && hi <= MOST_POSITIVE_FIXNUM))
1737 return -1;
1738 result->hi = hi;
1739 result->lo = lo;
1740 result->us = us;
1741 result->ps = ps;
1744 if (dresult)
1746 double dhi = hi;
1747 *dresult = (us * 1e6 + ps) / 1e12 + lo + dhi * (1 << LO_TIME_BITS);
1750 return 1;
1753 struct timespec
1754 lisp_to_timespec (struct lisp_time t)
1756 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> LO_TIME_BITS <= t.hi : 0 <= t.hi)
1757 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1758 return invalid_timespec ();
1759 time_t s = (t.hi << LO_TIME_BITS) + t.lo;
1760 int ns = t.us * 1000 + t.ps / 1000;
1761 return make_timespec (s, ns);
1764 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1765 Store its effective length into *PLEN.
1766 If SPECIFIED_TIME is nil, use the current time.
1767 Signal an error if SPECIFIED_TIME does not represent a time. */
1768 static struct lisp_time
1769 lisp_time_struct (Lisp_Object specified_time, int *plen)
1771 Lisp_Object high, low, usec, psec;
1772 struct lisp_time t;
1773 int len = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1774 int val = len ? decode_time_components (high, low, usec, psec, &t, 0) : 0;
1775 check_time_validity (val);
1776 *plen = len;
1777 return t;
1780 /* Like lisp_time_struct, except return a struct timespec.
1781 Discard any low-order digits. */
1782 struct timespec
1783 lisp_time_argument (Lisp_Object specified_time)
1785 int len;
1786 struct lisp_time lt = lisp_time_struct (specified_time, &len);
1787 struct timespec t = lisp_to_timespec (lt);
1788 if (! timespec_valid_p (t))
1789 time_overflow ();
1790 return t;
1793 /* Like lisp_time_argument, except decode only the seconds part,
1794 and do not check the subseconds part. */
1795 static time_t
1796 lisp_seconds_argument (Lisp_Object specified_time)
1798 Lisp_Object high, low, usec, psec;
1799 struct lisp_time t;
1801 int val = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1802 if (val != 0)
1804 val = decode_time_components (high, low, make_number (0),
1805 make_number (0), &t, 0);
1806 if (0 < val
1807 && ! ((TYPE_SIGNED (time_t)
1808 ? TIME_T_MIN >> LO_TIME_BITS <= t.hi
1809 : 0 <= t.hi)
1810 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1811 val = -1;
1813 check_time_validity (val);
1814 return (t.hi << LO_TIME_BITS) + t.lo;
1817 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1818 doc: /* Return the current time, as a float number of seconds since the epoch.
1819 If SPECIFIED-TIME is given, it is the time to convert to float
1820 instead of the current time. The argument should have the form
1821 (HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1822 you can use times from `current-time' and from `file-attributes'.
1823 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1824 considered obsolete.
1826 WARNING: Since the result is floating point, it may not be exact.
1827 If precise time stamps are required, use either `current-time',
1828 or (if you need time as a string) `format-time-string'. */)
1829 (Lisp_Object specified_time)
1831 double t;
1832 Lisp_Object high, low, usec, psec;
1833 if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
1834 && decode_time_components (high, low, usec, psec, 0, &t)))
1835 invalid_time ();
1836 return make_float (t);
1839 /* Write information into buffer S of size MAXSIZE, according to the
1840 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1841 Default to Universal Time if UT, local time otherwise.
1842 Use NS as the number of nanoseconds in the %N directive.
1843 Return the number of bytes written, not including the terminating
1844 '\0'. If S is NULL, nothing will be written anywhere; so to
1845 determine how many bytes would be written, use NULL for S and
1846 ((size_t) -1) for MAXSIZE.
1848 This function behaves like nstrftime, except it allows null
1849 bytes in FORMAT and it does not support nanoseconds. */
1850 static size_t
1851 emacs_nmemftime (char *s, size_t maxsize, const char *format,
1852 size_t format_len, const struct tm *tp, bool ut, int ns)
1854 size_t total = 0;
1856 /* Loop through all the null-terminated strings in the format
1857 argument. Normally there's just one null-terminated string, but
1858 there can be arbitrarily many, concatenated together, if the
1859 format contains '\0' bytes. nstrftime stops at the first
1860 '\0' byte so we must invoke it separately for each such string. */
1861 for (;;)
1863 size_t len;
1864 size_t result;
1866 if (s)
1867 s[0] = '\1';
1869 result = nstrftime (s, maxsize, format, tp, ut, ns);
1871 if (s)
1873 if (result == 0 && s[0] != '\0')
1874 return 0;
1875 s += result + 1;
1878 maxsize -= result + 1;
1879 total += result;
1880 len = strlen (format);
1881 if (len == format_len)
1882 return total;
1883 total++;
1884 format += len + 1;
1885 format_len -= len + 1;
1889 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
1890 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1891 TIME is specified as (HIGH LOW USEC PSEC), as returned by
1892 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1893 is also still accepted.
1894 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1895 as Universal Time; nil means describe TIME in the local time zone.
1896 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1897 by text that describes the specified date and time in TIME:
1899 %Y is the year, %y within the century, %C the century.
1900 %G is the year corresponding to the ISO week, %g within the century.
1901 %m is the numeric month.
1902 %b and %h are the locale's abbreviated month name, %B the full name.
1903 (%h is not supported on MS-Windows.)
1904 %d is the day of the month, zero-padded, %e is blank-padded.
1905 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1906 %a is the locale's abbreviated name of the day of week, %A the full name.
1907 %U is the week number starting on Sunday, %W starting on Monday,
1908 %V according to ISO 8601.
1909 %j is the day of the year.
1911 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1912 only blank-padded, %l is like %I blank-padded.
1913 %p is the locale's equivalent of either AM or PM.
1914 %M is the minute.
1915 %S is the second.
1916 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1917 %Z is the time zone name, %z is the numeric form.
1918 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1920 %c is the locale's date and time format.
1921 %x is the locale's "preferred" date format.
1922 %D is like "%m/%d/%y".
1923 %F is the ISO 8601 date format (like "%Y-%m-%d").
1925 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1926 %X is the locale's "preferred" time format.
1928 Finally, %n is a newline, %t is a tab, %% is a literal %.
1930 Certain flags and modifiers are available with some format controls.
1931 The flags are `_', `-', `^' and `#'. For certain characters X,
1932 %_X is like %X, but padded with blanks; %-X is like %X,
1933 but without padding. %^X is like %X, but with all textual
1934 characters up-cased; %#X is like %X, but with letter-case of
1935 all textual characters reversed.
1936 %NX (where N stands for an integer) is like %X,
1937 but takes up at least N (a number) positions.
1938 The modifiers are `E' and `O'. For certain characters X,
1939 %EX is a locale's alternative version of %X;
1940 %OX is like %X, but uses the locale's number symbols.
1942 For example, to produce full ISO 8601 format, use "%FT%T%z".
1944 usage: (format-time-string FORMAT-STRING &optional TIME UNIVERSAL) */)
1945 (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object universal)
1947 struct timespec t = lisp_time_argument (timeval);
1948 struct tm tm;
1950 CHECK_STRING (format_string);
1951 format_string = code_convert_string_norecord (format_string,
1952 Vlocale_coding_system, 1);
1953 return format_time_string (SSDATA (format_string), SBYTES (format_string),
1954 t, ! NILP (universal), &tm);
1957 static Lisp_Object
1958 format_time_string (char const *format, ptrdiff_t formatlen,
1959 struct timespec t, bool ut, struct tm *tmp)
1961 char buffer[4000];
1962 char *buf = buffer;
1963 ptrdiff_t size = sizeof buffer;
1964 size_t len;
1965 Lisp_Object bufstring;
1966 int ns = t.tv_nsec;
1967 USE_SAFE_ALLOCA;
1969 tmp = ut ? gmtime_r (&t.tv_sec, tmp) : localtime_r (&t.tv_sec, tmp);
1970 if (! tmp)
1971 time_overflow ();
1972 synchronize_system_time_locale ();
1974 while (true)
1976 buf[0] = '\1';
1977 len = emacs_nmemftime (buf, size, format, formatlen, tmp, ut, ns);
1978 if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
1979 break;
1981 /* Buffer was too small, so make it bigger and try again. */
1982 len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, ut, ns);
1983 if (STRING_BYTES_BOUND <= len)
1984 string_overflow ();
1985 size = len + 1;
1986 buf = SAFE_ALLOCA (size);
1989 bufstring = make_unibyte_string (buf, len);
1990 SAFE_FREE ();
1991 return code_convert_string_norecord (bufstring, Vlocale_coding_system, 0);
1994 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0,
1995 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1996 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1997 as from `current-time' and `file-attributes', or nil to use the
1998 current time. The obsolete form (HIGH . LOW) is also still accepted.
1999 The list has the following nine members: SEC is an integer between 0
2000 and 60; SEC is 60 for a leap second, which only some operating systems
2001 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2002 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2003 integer between 1 and 12. YEAR is an integer indicating the
2004 four-digit year. DOW is the day of week, an integer between 0 and 6,
2005 where 0 is Sunday. DST is t if daylight saving time is in effect,
2006 otherwise nil. ZONE is an integer indicating the number of seconds
2007 east of Greenwich. (Note that Common Lisp has different meanings for
2008 DOW and ZONE.) */)
2009 (Lisp_Object specified_time)
2011 time_t time_spec = lisp_seconds_argument (specified_time);
2012 struct tm local_tm, gmt_tm;
2014 if (! (localtime_r (&time_spec, &local_tm)
2015 && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
2016 && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE))
2017 time_overflow ();
2019 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2020 EMACS_INT tm_year_base = TM_YEAR_BASE;
2022 return CALLN (Flist,
2023 make_number (local_tm.tm_sec),
2024 make_number (local_tm.tm_min),
2025 make_number (local_tm.tm_hour),
2026 make_number (local_tm.tm_mday),
2027 make_number (local_tm.tm_mon + 1),
2028 make_number (local_tm.tm_year + tm_year_base),
2029 make_number (local_tm.tm_wday),
2030 local_tm.tm_isdst ? Qt : Qnil,
2031 (HAVE_TM_GMTOFF
2032 ? make_number (tm_gmtoff (&local_tm))
2033 : gmtime_r (&time_spec, &gmt_tm)
2034 ? make_number (tm_diff (&local_tm, &gmt_tm))
2035 : Qnil));
2038 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2039 the result is representable as an int. Assume OFFSET is small and
2040 nonnegative. */
2041 static int
2042 check_tm_member (Lisp_Object obj, int offset)
2044 EMACS_INT n;
2045 CHECK_NUMBER (obj);
2046 n = XINT (obj);
2047 if (! (INT_MIN + offset <= n && n - offset <= INT_MAX))
2048 time_overflow ();
2049 return n - offset;
2052 /* Decode ZONE as a time zone specification. */
2054 static Lisp_Object
2055 decode_time_zone (Lisp_Object zone)
2057 if (EQ (zone, Qt))
2058 return build_string ("UTC0");
2059 else if (STRINGP (zone))
2060 return zone;
2061 else if (INTEGERP (zone))
2063 static char const tzbuf_format[] = "XXX%s%"pI"d:%02d:%02d";
2064 char tzbuf[sizeof tzbuf_format + INT_STRLEN_BOUND (EMACS_INT)];
2065 EMACS_INT abszone = eabs (XINT (zone)), zone_hr = abszone / (60 * 60);
2066 int zone_min = (abszone / 60) % 60, zone_sec = abszone % 60;
2068 return make_formatted_string (tzbuf, tzbuf_format, &"-"[XINT (zone) < 0],
2069 zone_hr, zone_min, zone_sec);
2071 else
2072 xsignal2 (Qerror, build_string ("Invalid time zone specification"), zone);
2075 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
2076 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2077 This is the reverse operation of `decode-time', which see.
2078 ZONE defaults to the current time zone rule. This can
2079 be a string or t (as from `set-time-zone-rule'), or it can be a list
2080 \(as from `current-time-zone') or an integer (as from `decode-time')
2081 applied without consideration for daylight saving time.
2083 You can pass more than 7 arguments; then the first six arguments
2084 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2085 The intervening arguments are ignored.
2086 This feature lets (apply 'encode-time (decode-time ...)) work.
2088 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2089 for example, a DAY of 0 means the day preceding the given month.
2090 Year numbers less than 100 are treated just like other year numbers.
2091 If you want them to stand for years in this century, you must do that yourself.
2093 Years before 1970 are not guaranteed to work. On some systems,
2094 year values as low as 1901 do work.
2096 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2097 (ptrdiff_t nargs, Lisp_Object *args)
2099 time_t value;
2100 struct tm tm;
2101 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
2103 tm.tm_sec = check_tm_member (args[0], 0);
2104 tm.tm_min = check_tm_member (args[1], 0);
2105 tm.tm_hour = check_tm_member (args[2], 0);
2106 tm.tm_mday = check_tm_member (args[3], 0);
2107 tm.tm_mon = check_tm_member (args[4], 1);
2108 tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
2109 tm.tm_isdst = -1;
2111 if (CONSP (zone))
2112 zone = XCAR (zone);
2113 if (NILP (zone))
2114 value = mktime (&tm);
2115 else
2117 timezone_t tz = tzalloc (SSDATA (decode_time_zone (zone)));
2118 value = mktime_z (tz, &tm);
2119 tzfree (tz);
2122 if (value == (time_t) -1)
2123 time_overflow ();
2125 return list2i (hi_time (value), lo_time (value));
2128 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
2129 doc: /* Return the current local time, as a human-readable string.
2130 Programs can use this function to decode a time,
2131 since the number of columns in each field is fixed
2132 if the year is in the range 1000-9999.
2133 The format is `Sun Sep 16 01:03:52 1973'.
2134 However, see also the functions `decode-time' and `format-time-string'
2135 which provide a much more powerful and general facility.
2137 If SPECIFIED-TIME is given, it is a time to format instead of the
2138 current time. The argument should have the form (HIGH LOW . IGNORED).
2139 Thus, you can use times obtained from `current-time' and from
2140 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2141 but this is considered obsolete. */)
2142 (Lisp_Object specified_time)
2144 time_t value = lisp_seconds_argument (specified_time);
2146 /* Convert to a string in ctime format, except without the trailing
2147 newline, and without the 4-digit year limit. Don't use asctime
2148 or ctime, as they might dump core if the year is outside the
2149 range -999 .. 9999. */
2150 struct tm tm;
2151 if (! localtime_r (&value, &tm))
2152 time_overflow ();
2154 static char const wday_name[][4] =
2155 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2156 static char const mon_name[][4] =
2157 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2158 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2159 printmax_t year_base = TM_YEAR_BASE;
2160 char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2161 int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
2162 wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
2163 tm.tm_hour, tm.tm_min, tm.tm_sec,
2164 tm.tm_year + year_base);
2166 return make_unibyte_string (buf, len);
2169 /* Yield A - B, measured in seconds.
2170 This function is copied from the GNU C Library. */
2171 static int
2172 tm_diff (struct tm *a, struct tm *b)
2174 /* Compute intervening leap days correctly even if year is negative.
2175 Take care to avoid int overflow in leap day calculations,
2176 but it's OK to assume that A and B are close to each other. */
2177 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
2178 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
2179 int a100 = a4 / 25 - (a4 % 25 < 0);
2180 int b100 = b4 / 25 - (b4 % 25 < 0);
2181 int a400 = a100 >> 2;
2182 int b400 = b100 >> 2;
2183 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
2184 int years = a->tm_year - b->tm_year;
2185 int days = (365 * years + intervening_leap_days
2186 + (a->tm_yday - b->tm_yday));
2187 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
2188 + (a->tm_min - b->tm_min))
2189 + (a->tm_sec - b->tm_sec));
2192 /* Yield A's UTC offset, or an unspecified value if unknown. */
2193 static long int
2194 tm_gmtoff (struct tm *a)
2196 #if HAVE_TM_GMTOFF
2197 return a->tm_gmtoff;
2198 #else
2199 return 0;
2200 #endif
2203 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
2204 doc: /* Return the offset and name for the local time zone.
2205 This returns a list of the form (OFFSET NAME).
2206 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2207 A negative value means west of Greenwich.
2208 NAME is a string giving the name of the time zone.
2209 If SPECIFIED-TIME is given, the time zone offset is determined from it
2210 instead of using the current time. The argument should have the form
2211 (HIGH LOW . IGNORED). Thus, you can use times obtained from
2212 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2213 have the form (HIGH . LOW), but this is considered obsolete.
2215 Some operating systems cannot provide all this information to Emacs;
2216 in this case, `current-time-zone' returns a list containing nil for
2217 the data it can't find. */)
2218 (Lisp_Object specified_time)
2220 struct timespec value;
2221 struct tm local_tm, gmt_tm;
2222 Lisp_Object zone_offset, zone_name;
2224 zone_offset = Qnil;
2225 value = make_timespec (lisp_seconds_argument (specified_time), 0);
2226 zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value, 0, &local_tm);
2228 if (HAVE_TM_GMTOFF || gmtime_r (&value.tv_sec, &gmt_tm))
2230 long int offset = (HAVE_TM_GMTOFF
2231 ? tm_gmtoff (&local_tm)
2232 : tm_diff (&local_tm, &gmt_tm));
2233 zone_offset = make_number (offset);
2234 if (SCHARS (zone_name) == 0)
2236 /* No local time zone name is available; use "+-NNNN" instead. */
2237 long int m = offset / 60;
2238 long int am = offset < 0 ? - m : m;
2239 long int hour = am / 60;
2240 int min = am % 60;
2241 char buf[sizeof "+00" + INT_STRLEN_BOUND (long int)];
2242 zone_name = make_formatted_string (buf, "%c%02ld%02d",
2243 (offset < 0 ? '-' : '+'),
2244 hour, min);
2248 return list2 (zone_offset, zone_name);
2251 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
2252 doc: /* Set the local time zone using TZ, a string specifying a time zone rule.
2253 If TZ is nil, use implementation-defined default time zone information.
2254 If TZ is t, use Universal Time. If TZ is an integer, it is treated as in
2255 `encode-time'.
2257 Instead of calling this function, you typically want (setenv "TZ" TZ).
2258 That changes both the environment of the Emacs process and the
2259 variable `process-environment', whereas `set-time-zone-rule' affects
2260 only the former. */)
2261 (Lisp_Object tz)
2263 const char *tzstring = NILP (tz) ? initial_tz : SSDATA (decode_time_zone (tz));
2265 block_input ();
2266 set_time_zone_rule (tzstring);
2267 unblock_input ();
2269 return Qnil;
2272 /* Set the local time zone rule to TZSTRING.
2274 This function is not thread-safe, in theory because putenv is not,
2275 but mostly because of the static storage it updates. Other threads
2276 that invoke localtime etc. may be adversely affected while this
2277 function is executing. */
2279 static void
2280 set_time_zone_rule (const char *tzstring)
2282 /* A buffer holding a string of the form "TZ=value", intended
2283 to be part of the environment. */
2284 static char *tzvalbuf;
2285 static ptrdiff_t tzvalbufsize;
2287 int tzeqlen = sizeof "TZ=" - 1;
2288 ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
2289 char *tzval = tzvalbuf;
2290 bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
2292 if (new_tzvalbuf)
2294 /* Do not attempt to free the old tzvalbuf, since another thread
2295 may be using it. In practice, the first allocation is large
2296 enough and memory does not leak. */
2297 tzval = xpalloc (NULL, &tzvalbufsize,
2298 tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
2299 tzvalbuf = tzval;
2300 tzval[1] = 'Z';
2301 tzval[2] = '=';
2304 if (tzstring)
2306 /* Modify TZVAL in place. Although this is dicey in a
2307 multithreaded environment, we know of no portable alternative.
2308 Calling putenv or setenv could crash some other thread. */
2309 tzval[0] = 'T';
2310 strcpy (tzval + tzeqlen, tzstring);
2312 else
2314 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2315 Although this is also dicey, calling unsetenv here can crash Emacs.
2316 See Bug#8705. */
2317 tzval[0] = 't';
2318 tzval[tzeqlen] = 0;
2321 if (new_tzvalbuf)
2323 /* Although this is not thread-safe, in practice this runs only
2324 on startup when there is only one thread. */
2325 xputenv (tzval);
2328 #ifdef HAVE_TZSET
2329 tzset ();
2330 #endif
2333 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2334 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2335 type of object is Lisp_String). INHERIT is passed to
2336 INSERT_FROM_STRING_FUNC as the last argument. */
2338 static void
2339 general_insert_function (void (*insert_func)
2340 (const char *, ptrdiff_t),
2341 void (*insert_from_string_func)
2342 (Lisp_Object, ptrdiff_t, ptrdiff_t,
2343 ptrdiff_t, ptrdiff_t, bool),
2344 bool inherit, ptrdiff_t nargs, Lisp_Object *args)
2346 ptrdiff_t argnum;
2347 Lisp_Object val;
2349 for (argnum = 0; argnum < nargs; argnum++)
2351 val = args[argnum];
2352 if (CHARACTERP (val))
2354 int c = XFASTINT (val);
2355 unsigned char str[MAX_MULTIBYTE_LENGTH];
2356 int len;
2358 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2359 len = CHAR_STRING (c, str);
2360 else
2362 str[0] = CHAR_TO_BYTE8 (c);
2363 len = 1;
2365 (*insert_func) ((char *) str, len);
2367 else if (STRINGP (val))
2369 (*insert_from_string_func) (val, 0, 0,
2370 SCHARS (val),
2371 SBYTES (val),
2372 inherit);
2374 else
2375 wrong_type_argument (Qchar_or_string_p, val);
2379 void
2380 insert1 (Lisp_Object arg)
2382 Finsert (1, &arg);
2386 /* Callers passing one argument to Finsert need not gcpro the
2387 argument "array", since the only element of the array will
2388 not be used after calling insert or insert_from_string, so
2389 we don't care if it gets trashed. */
2391 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
2392 doc: /* Insert the arguments, either strings or characters, at point.
2393 Point and before-insertion markers move forward to end up
2394 after the inserted text.
2395 Any other markers at the point of insertion remain before the text.
2397 If the current buffer is multibyte, unibyte strings are converted
2398 to multibyte for insertion (see `string-make-multibyte').
2399 If the current buffer is unibyte, multibyte strings are converted
2400 to unibyte for insertion (see `string-make-unibyte').
2402 When operating on binary data, it may be necessary to preserve the
2403 original bytes of a unibyte string when inserting it into a multibyte
2404 buffer; to accomplish this, apply `string-as-multibyte' to the string
2405 and insert the result.
2407 usage: (insert &rest ARGS) */)
2408 (ptrdiff_t nargs, Lisp_Object *args)
2410 general_insert_function (insert, insert_from_string, 0, nargs, args);
2411 return Qnil;
2414 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
2415 0, MANY, 0,
2416 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
2417 Point and before-insertion markers move forward to end up
2418 after the inserted text.
2419 Any other markers at the point of insertion remain before the text.
2421 If the current buffer is multibyte, unibyte strings are converted
2422 to multibyte for insertion (see `unibyte-char-to-multibyte').
2423 If the current buffer is unibyte, multibyte strings are converted
2424 to unibyte for insertion.
2426 usage: (insert-and-inherit &rest ARGS) */)
2427 (ptrdiff_t nargs, Lisp_Object *args)
2429 general_insert_function (insert_and_inherit, insert_from_string, 1,
2430 nargs, args);
2431 return Qnil;
2434 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
2435 doc: /* Insert strings or characters at point, relocating markers after the text.
2436 Point and markers move forward to end up after the inserted text.
2438 If the current buffer is multibyte, unibyte strings are converted
2439 to multibyte for insertion (see `unibyte-char-to-multibyte').
2440 If the current buffer is unibyte, multibyte strings are converted
2441 to unibyte for insertion.
2443 If an overlay begins at the insertion point, the inserted text falls
2444 outside the overlay; if a nonempty overlay ends at the insertion
2445 point, the inserted text falls inside that overlay.
2447 usage: (insert-before-markers &rest ARGS) */)
2448 (ptrdiff_t nargs, Lisp_Object *args)
2450 general_insert_function (insert_before_markers,
2451 insert_from_string_before_markers, 0,
2452 nargs, args);
2453 return Qnil;
2456 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
2457 Sinsert_and_inherit_before_markers, 0, MANY, 0,
2458 doc: /* Insert text at point, relocating markers and inheriting properties.
2459 Point and markers move forward to end up after the inserted text.
2461 If the current buffer is multibyte, unibyte strings are converted
2462 to multibyte for insertion (see `unibyte-char-to-multibyte').
2463 If the current buffer is unibyte, multibyte strings are converted
2464 to unibyte for insertion.
2466 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2467 (ptrdiff_t nargs, Lisp_Object *args)
2469 general_insert_function (insert_before_markers_and_inherit,
2470 insert_from_string_before_markers, 1,
2471 nargs, args);
2472 return Qnil;
2475 DEFUN ("insert-char", Finsert_char, Sinsert_char, 1, 3,
2476 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2477 (prefix-numeric-value current-prefix-arg)\
2478 t))",
2479 doc: /* Insert COUNT copies of CHARACTER.
2480 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2481 of these ways:
2483 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2484 Completion is available; if you type a substring of the name
2485 preceded by an asterisk `*', Emacs shows all names which include
2486 that substring, not necessarily at the beginning of the name.
2488 - As a hexadecimal code point, e.g. 263A. Note that code points in
2489 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2490 the Unicode code space).
2492 - As a code point with a radix specified with #, e.g. #o21430
2493 (octal), #x2318 (hex), or #10r8984 (decimal).
2495 If called interactively, COUNT is given by the prefix argument. If
2496 omitted or nil, it defaults to 1.
2498 Inserting the character(s) relocates point and before-insertion
2499 markers in the same ways as the function `insert'.
2501 The optional third argument INHERIT, if non-nil, says to inherit text
2502 properties from adjoining text, if those properties are sticky. If
2503 called interactively, INHERIT is t. */)
2504 (Lisp_Object character, Lisp_Object count, Lisp_Object inherit)
2506 int i, stringlen;
2507 register ptrdiff_t n;
2508 int c, len;
2509 unsigned char str[MAX_MULTIBYTE_LENGTH];
2510 char string[4000];
2512 CHECK_CHARACTER (character);
2513 if (NILP (count))
2514 XSETFASTINT (count, 1);
2515 CHECK_NUMBER (count);
2516 c = XFASTINT (character);
2518 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2519 len = CHAR_STRING (c, str);
2520 else
2521 str[0] = c, len = 1;
2522 if (XINT (count) <= 0)
2523 return Qnil;
2524 if (BUF_BYTES_MAX / len < XINT (count))
2525 buffer_overflow ();
2526 n = XINT (count) * len;
2527 stringlen = min (n, sizeof string - sizeof string % len);
2528 for (i = 0; i < stringlen; i++)
2529 string[i] = str[i % len];
2530 while (n > stringlen)
2532 QUIT;
2533 if (!NILP (inherit))
2534 insert_and_inherit (string, stringlen);
2535 else
2536 insert (string, stringlen);
2537 n -= stringlen;
2539 if (!NILP (inherit))
2540 insert_and_inherit (string, n);
2541 else
2542 insert (string, n);
2543 return Qnil;
2546 DEFUN ("insert-byte", Finsert_byte, Sinsert_byte, 2, 3, 0,
2547 doc: /* Insert COUNT (second arg) copies of BYTE (first arg).
2548 Both arguments are required.
2549 BYTE is a number of the range 0..255.
2551 If BYTE is 128..255 and the current buffer is multibyte, the
2552 corresponding eight-bit character is inserted.
2554 Point, and before-insertion markers, are relocated as in the function `insert'.
2555 The optional third arg INHERIT, if non-nil, says to inherit text properties
2556 from adjoining text, if those properties are sticky. */)
2557 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
2559 CHECK_NUMBER (byte);
2560 if (XINT (byte) < 0 || XINT (byte) > 255)
2561 args_out_of_range_3 (byte, make_number (0), make_number (255));
2562 if (XINT (byte) >= 128
2563 && ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2564 XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte)));
2565 return Finsert_char (byte, count, inherit);
2569 /* Making strings from buffer contents. */
2571 /* Return a Lisp_String containing the text of the current buffer from
2572 START to END. If text properties are in use and the current buffer
2573 has properties in the range specified, the resulting string will also
2574 have them, if PROPS is true.
2576 We don't want to use plain old make_string here, because it calls
2577 make_uninit_string, which can cause the buffer arena to be
2578 compacted. make_string has no way of knowing that the data has
2579 been moved, and thus copies the wrong data into the string. This
2580 doesn't effect most of the other users of make_string, so it should
2581 be left as is. But we should use this function when conjuring
2582 buffer substrings. */
2584 Lisp_Object
2585 make_buffer_string (ptrdiff_t start, ptrdiff_t end, bool props)
2587 ptrdiff_t start_byte = CHAR_TO_BYTE (start);
2588 ptrdiff_t end_byte = CHAR_TO_BYTE (end);
2590 return make_buffer_string_both (start, start_byte, end, end_byte, props);
2593 /* Return a Lisp_String containing the text of the current buffer from
2594 START / START_BYTE to END / END_BYTE.
2596 If text properties are in use and the current buffer
2597 has properties in the range specified, the resulting string will also
2598 have them, if PROPS is true.
2600 We don't want to use plain old make_string here, because it calls
2601 make_uninit_string, which can cause the buffer arena to be
2602 compacted. make_string has no way of knowing that the data has
2603 been moved, and thus copies the wrong data into the string. This
2604 doesn't effect most of the other users of make_string, so it should
2605 be left as is. But we should use this function when conjuring
2606 buffer substrings. */
2608 Lisp_Object
2609 make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
2610 ptrdiff_t end, ptrdiff_t end_byte, bool props)
2612 Lisp_Object result, tem, tem1;
2613 ptrdiff_t beg0, end0, beg1, end1, size;
2615 if (start_byte < GPT_BYTE && GPT_BYTE < end_byte)
2617 /* Two regions, before and after the gap. */
2618 beg0 = start_byte;
2619 end0 = GPT_BYTE;
2620 beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
2621 end1 = end_byte + GAP_SIZE - BEG_BYTE;
2623 else
2625 /* The only region. */
2626 beg0 = start_byte;
2627 end0 = end_byte;
2628 beg1 = -1;
2629 end1 = -1;
2632 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2633 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
2634 else
2635 result = make_uninit_string (end - start);
2637 size = end0 - beg0;
2638 memcpy (SDATA (result), BYTE_POS_ADDR (beg0), size);
2639 if (beg1 != -1)
2640 memcpy (SDATA (result) + size, BEG_ADDR + beg1, end1 - beg1);
2642 /* If desired, update and copy the text properties. */
2643 if (props)
2645 update_buffer_properties (start, end);
2647 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
2648 tem1 = Ftext_properties_at (make_number (start), Qnil);
2650 if (XINT (tem) != end || !NILP (tem1))
2651 copy_intervals_to_string (result, current_buffer, start,
2652 end - start);
2655 return result;
2658 /* Call Vbuffer_access_fontify_functions for the range START ... END
2659 in the current buffer, if necessary. */
2661 static void
2662 update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
2664 /* If this buffer has some access functions,
2665 call them, specifying the range of the buffer being accessed. */
2666 if (!NILP (Vbuffer_access_fontify_functions))
2668 /* But don't call them if we can tell that the work
2669 has already been done. */
2670 if (!NILP (Vbuffer_access_fontified_property))
2672 Lisp_Object tem
2673 = Ftext_property_any (make_number (start), make_number (end),
2674 Vbuffer_access_fontified_property,
2675 Qnil, Qnil);
2676 if (NILP (tem))
2677 return;
2680 CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions,
2681 make_number (start), make_number (end));
2685 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
2686 doc: /* Return the contents of part of the current buffer as a string.
2687 The two arguments START and END are character positions;
2688 they can be in either order.
2689 The string returned is multibyte if the buffer is multibyte.
2691 This function copies the text properties of that part of the buffer
2692 into the result string; if you don't want the text properties,
2693 use `buffer-substring-no-properties' instead. */)
2694 (Lisp_Object start, Lisp_Object end)
2696 register ptrdiff_t b, e;
2698 validate_region (&start, &end);
2699 b = XINT (start);
2700 e = XINT (end);
2702 return make_buffer_string (b, e, 1);
2705 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
2706 Sbuffer_substring_no_properties, 2, 2, 0,
2707 doc: /* Return the characters of part of the buffer, without the text properties.
2708 The two arguments START and END are character positions;
2709 they can be in either order. */)
2710 (Lisp_Object start, Lisp_Object end)
2712 register ptrdiff_t b, e;
2714 validate_region (&start, &end);
2715 b = XINT (start);
2716 e = XINT (end);
2718 return make_buffer_string (b, e, 0);
2721 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
2722 doc: /* Return the contents of the current buffer as a string.
2723 If narrowing is in effect, this function returns only the visible part
2724 of the buffer. */)
2725 (void)
2727 return make_buffer_string_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, 1);
2730 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
2731 1, 3, 0,
2732 doc: /* Insert before point a substring of the contents of BUFFER.
2733 BUFFER may be a buffer or a buffer name.
2734 Arguments START and END are character positions specifying the substring.
2735 They default to the values of (point-min) and (point-max) in BUFFER.
2737 Point and before-insertion markers move forward to end up after the
2738 inserted text.
2739 Any other markers at the point of insertion remain before the text.
2741 If the current buffer is multibyte and BUFFER is unibyte, or vice
2742 versa, strings are converted from unibyte to multibyte or vice versa
2743 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2744 (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
2746 register EMACS_INT b, e, temp;
2747 register struct buffer *bp, *obuf;
2748 Lisp_Object buf;
2750 buf = Fget_buffer (buffer);
2751 if (NILP (buf))
2752 nsberror (buffer);
2753 bp = XBUFFER (buf);
2754 if (!BUFFER_LIVE_P (bp))
2755 error ("Selecting deleted buffer");
2757 if (NILP (start))
2758 b = BUF_BEGV (bp);
2759 else
2761 CHECK_NUMBER_COERCE_MARKER (start);
2762 b = XINT (start);
2764 if (NILP (end))
2765 e = BUF_ZV (bp);
2766 else
2768 CHECK_NUMBER_COERCE_MARKER (end);
2769 e = XINT (end);
2772 if (b > e)
2773 temp = b, b = e, e = temp;
2775 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
2776 args_out_of_range (start, end);
2778 obuf = current_buffer;
2779 set_buffer_internal_1 (bp);
2780 update_buffer_properties (b, e);
2781 set_buffer_internal_1 (obuf);
2783 insert_from_buffer (bp, b, e - b, 0);
2784 return Qnil;
2787 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
2788 6, 6, 0,
2789 doc: /* Compare two substrings of two buffers; return result as number.
2790 Return -N if first string is less after N-1 chars, +N if first string is
2791 greater after N-1 chars, or 0 if strings match. Each substring is
2792 represented as three arguments: BUFFER, START and END. That makes six
2793 args in all, three for each substring.
2795 The value of `case-fold-search' in the current buffer
2796 determines whether case is significant or ignored. */)
2797 (Lisp_Object buffer1, Lisp_Object start1, Lisp_Object end1, Lisp_Object buffer2, Lisp_Object start2, Lisp_Object end2)
2799 register EMACS_INT begp1, endp1, begp2, endp2, temp;
2800 register struct buffer *bp1, *bp2;
2801 register Lisp_Object trt
2802 = (!NILP (BVAR (current_buffer, case_fold_search))
2803 ? BVAR (current_buffer, case_canon_table) : Qnil);
2804 ptrdiff_t chars = 0;
2805 ptrdiff_t i1, i2, i1_byte, i2_byte;
2807 /* Find the first buffer and its substring. */
2809 if (NILP (buffer1))
2810 bp1 = current_buffer;
2811 else
2813 Lisp_Object buf1;
2814 buf1 = Fget_buffer (buffer1);
2815 if (NILP (buf1))
2816 nsberror (buffer1);
2817 bp1 = XBUFFER (buf1);
2818 if (!BUFFER_LIVE_P (bp1))
2819 error ("Selecting deleted buffer");
2822 if (NILP (start1))
2823 begp1 = BUF_BEGV (bp1);
2824 else
2826 CHECK_NUMBER_COERCE_MARKER (start1);
2827 begp1 = XINT (start1);
2829 if (NILP (end1))
2830 endp1 = BUF_ZV (bp1);
2831 else
2833 CHECK_NUMBER_COERCE_MARKER (end1);
2834 endp1 = XINT (end1);
2837 if (begp1 > endp1)
2838 temp = begp1, begp1 = endp1, endp1 = temp;
2840 if (!(BUF_BEGV (bp1) <= begp1
2841 && begp1 <= endp1
2842 && endp1 <= BUF_ZV (bp1)))
2843 args_out_of_range (start1, end1);
2845 /* Likewise for second substring. */
2847 if (NILP (buffer2))
2848 bp2 = current_buffer;
2849 else
2851 Lisp_Object buf2;
2852 buf2 = Fget_buffer (buffer2);
2853 if (NILP (buf2))
2854 nsberror (buffer2);
2855 bp2 = XBUFFER (buf2);
2856 if (!BUFFER_LIVE_P (bp2))
2857 error ("Selecting deleted buffer");
2860 if (NILP (start2))
2861 begp2 = BUF_BEGV (bp2);
2862 else
2864 CHECK_NUMBER_COERCE_MARKER (start2);
2865 begp2 = XINT (start2);
2867 if (NILP (end2))
2868 endp2 = BUF_ZV (bp2);
2869 else
2871 CHECK_NUMBER_COERCE_MARKER (end2);
2872 endp2 = XINT (end2);
2875 if (begp2 > endp2)
2876 temp = begp2, begp2 = endp2, endp2 = temp;
2878 if (!(BUF_BEGV (bp2) <= begp2
2879 && begp2 <= endp2
2880 && endp2 <= BUF_ZV (bp2)))
2881 args_out_of_range (start2, end2);
2883 i1 = begp1;
2884 i2 = begp2;
2885 i1_byte = buf_charpos_to_bytepos (bp1, i1);
2886 i2_byte = buf_charpos_to_bytepos (bp2, i2);
2888 while (i1 < endp1 && i2 < endp2)
2890 /* When we find a mismatch, we must compare the
2891 characters, not just the bytes. */
2892 int c1, c2;
2894 QUIT;
2896 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
2898 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
2899 BUF_INC_POS (bp1, i1_byte);
2900 i1++;
2902 else
2904 c1 = BUF_FETCH_BYTE (bp1, i1);
2905 MAKE_CHAR_MULTIBYTE (c1);
2906 i1++;
2909 if (! NILP (BVAR (bp2, enable_multibyte_characters)))
2911 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
2912 BUF_INC_POS (bp2, i2_byte);
2913 i2++;
2915 else
2917 c2 = BUF_FETCH_BYTE (bp2, i2);
2918 MAKE_CHAR_MULTIBYTE (c2);
2919 i2++;
2922 if (!NILP (trt))
2924 c1 = char_table_translate (trt, c1);
2925 c2 = char_table_translate (trt, c2);
2927 if (c1 < c2)
2928 return make_number (- 1 - chars);
2929 if (c1 > c2)
2930 return make_number (chars + 1);
2932 chars++;
2935 /* The strings match as far as they go.
2936 If one is shorter, that one is less. */
2937 if (chars < endp1 - begp1)
2938 return make_number (chars + 1);
2939 else if (chars < endp2 - begp2)
2940 return make_number (- chars - 1);
2942 /* Same length too => they are equal. */
2943 return make_number (0);
2946 static void
2947 subst_char_in_region_unwind (Lisp_Object arg)
2949 bset_undo_list (current_buffer, arg);
2952 static void
2953 subst_char_in_region_unwind_1 (Lisp_Object arg)
2955 bset_filename (current_buffer, arg);
2958 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
2959 Ssubst_char_in_region, 4, 5, 0,
2960 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2961 If optional arg NOUNDO is non-nil, don't record this change for undo
2962 and don't mark the buffer as really changed.
2963 Both characters must have the same length of multi-byte form. */)
2964 (Lisp_Object start, Lisp_Object end, Lisp_Object fromchar, Lisp_Object tochar, Lisp_Object noundo)
2966 register ptrdiff_t pos, pos_byte, stop, i, len, end_byte;
2967 /* Keep track of the first change in the buffer:
2968 if 0 we haven't found it yet.
2969 if < 0 we've found it and we've run the before-change-function.
2970 if > 0 we've actually performed it and the value is its position. */
2971 ptrdiff_t changed = 0;
2972 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
2973 unsigned char *p;
2974 ptrdiff_t count = SPECPDL_INDEX ();
2975 #define COMBINING_NO 0
2976 #define COMBINING_BEFORE 1
2977 #define COMBINING_AFTER 2
2978 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2979 int maybe_byte_combining = COMBINING_NO;
2980 ptrdiff_t last_changed = 0;
2981 bool multibyte_p
2982 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
2983 int fromc, toc;
2985 restart:
2987 validate_region (&start, &end);
2988 CHECK_CHARACTER (fromchar);
2989 CHECK_CHARACTER (tochar);
2990 fromc = XFASTINT (fromchar);
2991 toc = XFASTINT (tochar);
2993 if (multibyte_p)
2995 len = CHAR_STRING (fromc, fromstr);
2996 if (CHAR_STRING (toc, tostr) != len)
2997 error ("Characters in `subst-char-in-region' have different byte-lengths");
2998 if (!ASCII_CHAR_P (*tostr))
3000 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3001 complete multibyte character, it may be combined with the
3002 after bytes. If it is in the range 0xA0..0xFF, it may be
3003 combined with the before and after bytes. */
3004 if (!CHAR_HEAD_P (*tostr))
3005 maybe_byte_combining = COMBINING_BOTH;
3006 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
3007 maybe_byte_combining = COMBINING_AFTER;
3010 else
3012 len = 1;
3013 fromstr[0] = fromc;
3014 tostr[0] = toc;
3017 pos = XINT (start);
3018 pos_byte = CHAR_TO_BYTE (pos);
3019 stop = CHAR_TO_BYTE (XINT (end));
3020 end_byte = stop;
3022 /* If we don't want undo, turn off putting stuff on the list.
3023 That's faster than getting rid of things,
3024 and it prevents even the entry for a first change.
3025 Also inhibit locking the file. */
3026 if (!changed && !NILP (noundo))
3028 record_unwind_protect (subst_char_in_region_unwind,
3029 BVAR (current_buffer, undo_list));
3030 bset_undo_list (current_buffer, Qt);
3031 /* Don't do file-locking. */
3032 record_unwind_protect (subst_char_in_region_unwind_1,
3033 BVAR (current_buffer, filename));
3034 bset_filename (current_buffer, Qnil);
3037 if (pos_byte < GPT_BYTE)
3038 stop = min (stop, GPT_BYTE);
3039 while (1)
3041 ptrdiff_t pos_byte_next = pos_byte;
3043 if (pos_byte >= stop)
3045 if (pos_byte >= end_byte) break;
3046 stop = end_byte;
3048 p = BYTE_POS_ADDR (pos_byte);
3049 if (multibyte_p)
3050 INC_POS (pos_byte_next);
3051 else
3052 ++pos_byte_next;
3053 if (pos_byte_next - pos_byte == len
3054 && p[0] == fromstr[0]
3055 && (len == 1
3056 || (p[1] == fromstr[1]
3057 && (len == 2 || (p[2] == fromstr[2]
3058 && (len == 3 || p[3] == fromstr[3]))))))
3060 if (changed < 0)
3061 /* We've already seen this and run the before-change-function;
3062 this time we only need to record the actual position. */
3063 changed = pos;
3064 else if (!changed)
3066 changed = -1;
3067 modify_text (pos, XINT (end));
3069 if (! NILP (noundo))
3071 if (MODIFF - 1 == SAVE_MODIFF)
3072 SAVE_MODIFF++;
3073 if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer))
3074 BUF_AUTOSAVE_MODIFF (current_buffer)++;
3077 /* The before-change-function may have moved the gap
3078 or even modified the buffer so we should start over. */
3079 goto restart;
3082 /* Take care of the case where the new character
3083 combines with neighboring bytes. */
3084 if (maybe_byte_combining
3085 && (maybe_byte_combining == COMBINING_AFTER
3086 ? (pos_byte_next < Z_BYTE
3087 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
3088 : ((pos_byte_next < Z_BYTE
3089 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
3090 || (pos_byte > BEG_BYTE
3091 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte - 1))))))
3093 Lisp_Object tem, string;
3095 struct gcpro gcpro1;
3097 tem = BVAR (current_buffer, undo_list);
3098 GCPRO1 (tem);
3100 /* Make a multibyte string containing this single character. */
3101 string = make_multibyte_string ((char *) tostr, 1, len);
3102 /* replace_range is less efficient, because it moves the gap,
3103 but it handles combining correctly. */
3104 replace_range (pos, pos + 1, string,
3105 0, 0, 1);
3106 pos_byte_next = CHAR_TO_BYTE (pos);
3107 if (pos_byte_next > pos_byte)
3108 /* Before combining happened. We should not increment
3109 POS. So, to cancel the later increment of POS,
3110 decrease it now. */
3111 pos--;
3112 else
3113 INC_POS (pos_byte_next);
3115 if (! NILP (noundo))
3116 bset_undo_list (current_buffer, tem);
3118 UNGCPRO;
3120 else
3122 if (NILP (noundo))
3123 record_change (pos, 1);
3124 for (i = 0; i < len; i++) *p++ = tostr[i];
3126 last_changed = pos + 1;
3128 pos_byte = pos_byte_next;
3129 pos++;
3132 if (changed > 0)
3134 signal_after_change (changed,
3135 last_changed - changed, last_changed - changed);
3136 update_compositions (changed, last_changed, CHECK_ALL);
3139 unbind_to (count, Qnil);
3140 return Qnil;
3144 static Lisp_Object check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3145 Lisp_Object);
3147 /* Helper function for Ftranslate_region_internal.
3149 Check if a character sequence at POS (POS_BYTE) matches an element
3150 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3151 element is found, return it. Otherwise return Qnil. */
3153 static Lisp_Object
3154 check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end,
3155 Lisp_Object val)
3157 int initial_buf[16];
3158 int *buf = initial_buf;
3159 ptrdiff_t buf_size = ARRAYELTS (initial_buf);
3160 int *bufalloc = 0;
3161 ptrdiff_t buf_used = 0;
3162 Lisp_Object result = Qnil;
3164 for (; CONSP (val); val = XCDR (val))
3166 Lisp_Object elt;
3167 ptrdiff_t len, i;
3169 elt = XCAR (val);
3170 if (! CONSP (elt))
3171 continue;
3172 elt = XCAR (elt);
3173 if (! VECTORP (elt))
3174 continue;
3175 len = ASIZE (elt);
3176 if (len <= end - pos)
3178 for (i = 0; i < len; i++)
3180 if (buf_used <= i)
3182 unsigned char *p = BYTE_POS_ADDR (pos_byte);
3183 int len1;
3185 if (buf_used == buf_size)
3187 bufalloc = xpalloc (bufalloc, &buf_size, 1, -1,
3188 sizeof *bufalloc);
3189 if (buf == initial_buf)
3190 memcpy (bufalloc, buf, sizeof initial_buf);
3191 buf = bufalloc;
3193 buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1);
3194 pos_byte += len1;
3196 if (XINT (AREF (elt, i)) != buf[i])
3197 break;
3199 if (i == len)
3201 result = XCAR (val);
3202 break;
3207 xfree (bufalloc);
3208 return result;
3212 DEFUN ("translate-region-internal", Ftranslate_region_internal,
3213 Stranslate_region_internal, 3, 3, 0,
3214 doc: /* Internal use only.
3215 From START to END, translate characters according to TABLE.
3216 TABLE is a string or a char-table; the Nth character in it is the
3217 mapping for the character with code N.
3218 It returns the number of characters changed. */)
3219 (Lisp_Object start, Lisp_Object end, register Lisp_Object table)
3221 register unsigned char *tt; /* Trans table. */
3222 register int nc; /* New character. */
3223 int cnt; /* Number of changes made. */
3224 ptrdiff_t size; /* Size of translate table. */
3225 ptrdiff_t pos, pos_byte, end_pos;
3226 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3227 bool string_multibyte IF_LINT (= 0);
3229 validate_region (&start, &end);
3230 if (CHAR_TABLE_P (table))
3232 if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
3233 error ("Not a translation table");
3234 size = MAX_CHAR;
3235 tt = NULL;
3237 else
3239 CHECK_STRING (table);
3241 if (! multibyte && (SCHARS (table) < SBYTES (table)))
3242 table = string_make_unibyte (table);
3243 string_multibyte = SCHARS (table) < SBYTES (table);
3244 size = SBYTES (table);
3245 tt = SDATA (table);
3248 pos = XINT (start);
3249 pos_byte = CHAR_TO_BYTE (pos);
3250 end_pos = XINT (end);
3251 modify_text (pos, end_pos);
3253 cnt = 0;
3254 for (; pos < end_pos; )
3256 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
3257 unsigned char *str, buf[MAX_MULTIBYTE_LENGTH];
3258 int len, str_len;
3259 int oc;
3260 Lisp_Object val;
3262 if (multibyte)
3263 oc = STRING_CHAR_AND_LENGTH (p, len);
3264 else
3265 oc = *p, len = 1;
3266 if (oc < size)
3268 if (tt)
3270 /* Reload as signal_after_change in last iteration may GC. */
3271 tt = SDATA (table);
3272 if (string_multibyte)
3274 str = tt + string_char_to_byte (table, oc);
3275 nc = STRING_CHAR_AND_LENGTH (str, str_len);
3277 else
3279 nc = tt[oc];
3280 if (! ASCII_CHAR_P (nc) && multibyte)
3282 str_len = BYTE8_STRING (nc, buf);
3283 str = buf;
3285 else
3287 str_len = 1;
3288 str = tt + oc;
3292 else
3294 nc = oc;
3295 val = CHAR_TABLE_REF (table, oc);
3296 if (CHARACTERP (val))
3298 nc = XFASTINT (val);
3299 str_len = CHAR_STRING (nc, buf);
3300 str = buf;
3302 else if (VECTORP (val) || (CONSP (val)))
3304 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3305 where TO is TO-CHAR or [TO-CHAR ...]. */
3306 nc = -1;
3310 if (nc != oc && nc >= 0)
3312 /* Simple one char to one char translation. */
3313 if (len != str_len)
3315 Lisp_Object string;
3317 /* This is less efficient, because it moves the gap,
3318 but it should handle multibyte characters correctly. */
3319 string = make_multibyte_string ((char *) str, 1, str_len);
3320 replace_range (pos, pos + 1, string, 1, 0, 1);
3321 len = str_len;
3323 else
3325 record_change (pos, 1);
3326 while (str_len-- > 0)
3327 *p++ = *str++;
3328 signal_after_change (pos, 1, 1);
3329 update_compositions (pos, pos + 1, CHECK_BORDER);
3331 ++cnt;
3333 else if (nc < 0)
3335 Lisp_Object string;
3337 if (CONSP (val))
3339 val = check_translation (pos, pos_byte, end_pos, val);
3340 if (NILP (val))
3342 pos_byte += len;
3343 pos++;
3344 continue;
3346 /* VAL is ([FROM-CHAR ...] . TO). */
3347 len = ASIZE (XCAR (val));
3348 val = XCDR (val);
3350 else
3351 len = 1;
3353 if (VECTORP (val))
3355 string = Fconcat (1, &val);
3357 else
3359 string = Fmake_string (make_number (1), val);
3361 replace_range (pos, pos + len, string, 1, 0, 1);
3362 pos_byte += SBYTES (string);
3363 pos += SCHARS (string);
3364 cnt += SCHARS (string);
3365 end_pos += SCHARS (string) - len;
3366 continue;
3369 pos_byte += len;
3370 pos++;
3373 return make_number (cnt);
3376 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
3377 doc: /* Delete the text between START and END.
3378 If called interactively, delete the region between point and mark.
3379 This command deletes buffer text without modifying the kill ring. */)
3380 (Lisp_Object start, Lisp_Object end)
3382 validate_region (&start, &end);
3383 del_range (XINT (start), XINT (end));
3384 return Qnil;
3387 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
3388 Sdelete_and_extract_region, 2, 2, 0,
3389 doc: /* Delete the text between START and END and return it. */)
3390 (Lisp_Object start, Lisp_Object end)
3392 validate_region (&start, &end);
3393 if (XINT (start) == XINT (end))
3394 return empty_unibyte_string;
3395 return del_range_1 (XINT (start), XINT (end), 1, 1);
3398 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
3399 doc: /* Remove restrictions (narrowing) from current buffer.
3400 This allows the buffer's full text to be seen and edited. */)
3401 (void)
3403 if (BEG != BEGV || Z != ZV)
3404 current_buffer->clip_changed = 1;
3405 BEGV = BEG;
3406 BEGV_BYTE = BEG_BYTE;
3407 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
3408 /* Changing the buffer bounds invalidates any recorded current column. */
3409 invalidate_current_column ();
3410 return Qnil;
3413 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
3414 doc: /* Restrict editing in this buffer to the current region.
3415 The rest of the text becomes temporarily invisible and untouchable
3416 but is not deleted; if you save the buffer in a file, the invisible
3417 text is included in the file. \\[widen] makes all visible again.
3418 See also `save-restriction'.
3420 When calling from a program, pass two arguments; positions (integers
3421 or markers) bounding the text that should remain visible. */)
3422 (register Lisp_Object start, Lisp_Object end)
3424 CHECK_NUMBER_COERCE_MARKER (start);
3425 CHECK_NUMBER_COERCE_MARKER (end);
3427 if (XINT (start) > XINT (end))
3429 Lisp_Object tem;
3430 tem = start; start = end; end = tem;
3433 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
3434 args_out_of_range (start, end);
3436 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
3437 current_buffer->clip_changed = 1;
3439 SET_BUF_BEGV (current_buffer, XFASTINT (start));
3440 SET_BUF_ZV (current_buffer, XFASTINT (end));
3441 if (PT < XFASTINT (start))
3442 SET_PT (XFASTINT (start));
3443 if (PT > XFASTINT (end))
3444 SET_PT (XFASTINT (end));
3445 /* Changing the buffer bounds invalidates any recorded current column. */
3446 invalidate_current_column ();
3447 return Qnil;
3450 Lisp_Object
3451 save_restriction_save (void)
3453 if (BEGV == BEG && ZV == Z)
3454 /* The common case that the buffer isn't narrowed.
3455 We return just the buffer object, which save_restriction_restore
3456 recognizes as meaning `no restriction'. */
3457 return Fcurrent_buffer ();
3458 else
3459 /* We have to save a restriction, so return a pair of markers, one
3460 for the beginning and one for the end. */
3462 Lisp_Object beg, end;
3464 beg = build_marker (current_buffer, BEGV, BEGV_BYTE);
3465 end = build_marker (current_buffer, ZV, ZV_BYTE);
3467 /* END must move forward if text is inserted at its exact location. */
3468 XMARKER (end)->insertion_type = 1;
3470 return Fcons (beg, end);
3474 void
3475 save_restriction_restore (Lisp_Object data)
3477 struct buffer *cur = NULL;
3478 struct buffer *buf = (CONSP (data)
3479 ? XMARKER (XCAR (data))->buffer
3480 : XBUFFER (data));
3482 if (buf && buf != current_buffer && !NILP (BVAR (buf, pt_marker)))
3483 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3484 is the case if it is or has an indirect buffer), then make
3485 sure it is current before we update BEGV, so
3486 set_buffer_internal takes care of managing those markers. */
3487 cur = current_buffer;
3488 set_buffer_internal (buf);
3491 if (CONSP (data))
3492 /* A pair of marks bounding a saved restriction. */
3494 struct Lisp_Marker *beg = XMARKER (XCAR (data));
3495 struct Lisp_Marker *end = XMARKER (XCDR (data));
3496 eassert (buf == end->buffer);
3498 if (buf /* Verify marker still points to a buffer. */
3499 && (beg->charpos != BUF_BEGV (buf) || end->charpos != BUF_ZV (buf)))
3500 /* The restriction has changed from the saved one, so restore
3501 the saved restriction. */
3503 ptrdiff_t pt = BUF_PT (buf);
3505 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
3506 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
3508 if (pt < beg->charpos || pt > end->charpos)
3509 /* The point is outside the new visible range, move it inside. */
3510 SET_BUF_PT_BOTH (buf,
3511 clip_to_bounds (beg->charpos, pt, end->charpos),
3512 clip_to_bounds (beg->bytepos, BUF_PT_BYTE (buf),
3513 end->bytepos));
3515 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3517 /* These aren't needed anymore, so don't wait for GC. */
3518 free_marker (XCAR (data));
3519 free_marker (XCDR (data));
3520 free_cons (XCONS (data));
3522 else
3523 /* A buffer, which means that there was no old restriction. */
3525 if (buf /* Verify marker still points to a buffer. */
3526 && (BUF_BEGV (buf) != BUF_BEG (buf) || BUF_ZV (buf) != BUF_Z (buf)))
3527 /* The buffer has been narrowed, get rid of the narrowing. */
3529 SET_BUF_BEGV_BOTH (buf, BUF_BEG (buf), BUF_BEG_BYTE (buf));
3530 SET_BUF_ZV_BOTH (buf, BUF_Z (buf), BUF_Z_BYTE (buf));
3532 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3536 /* Changing the buffer bounds invalidates any recorded current column. */
3537 invalidate_current_column ();
3539 if (cur)
3540 set_buffer_internal (cur);
3543 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
3544 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
3545 The buffer's restrictions make parts of the beginning and end invisible.
3546 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3547 This special form, `save-restriction', saves the current buffer's restrictions
3548 when it is entered, and restores them when it is exited.
3549 So any `narrow-to-region' within BODY lasts only until the end of the form.
3550 The old restrictions settings are restored
3551 even in case of abnormal exit (throw or error).
3553 The value returned is the value of the last form in BODY.
3555 Note: if you are using both `save-excursion' and `save-restriction',
3556 use `save-excursion' outermost:
3557 (save-excursion (save-restriction ...))
3559 usage: (save-restriction &rest BODY) */)
3560 (Lisp_Object body)
3562 register Lisp_Object val;
3563 ptrdiff_t count = SPECPDL_INDEX ();
3565 record_unwind_protect (save_restriction_restore, save_restriction_save ());
3566 val = Fprogn (body);
3567 return unbind_to (count, val);
3570 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
3571 doc: /* Display a message at the bottom of the screen.
3572 The message also goes into the `*Messages*' buffer, if `message-log-max'
3573 is non-nil. (In keyboard macros, that's all it does.)
3574 Return the message.
3576 In batch mode, the message is printed to the standard error stream,
3577 followed by a newline.
3579 The first argument is a format control string, and the rest are data
3580 to be formatted under control of the string. See `format' for details.
3582 Note: Use (message "%s" VALUE) to print the value of expressions and
3583 variables to avoid accidentally interpreting `%' as format specifiers.
3585 If the first argument is nil or the empty string, the function clears
3586 any existing message; this lets the minibuffer contents show. See
3587 also `current-message'.
3589 usage: (message FORMAT-STRING &rest ARGS) */)
3590 (ptrdiff_t nargs, Lisp_Object *args)
3592 if (NILP (args[0])
3593 || (STRINGP (args[0])
3594 && SBYTES (args[0]) == 0))
3596 message1 (0);
3597 return args[0];
3599 else
3601 register Lisp_Object val;
3602 val = Fformat (nargs, args);
3603 message3 (val);
3604 return val;
3608 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
3609 doc: /* Display a message, in a dialog box if possible.
3610 If a dialog box is not available, use the echo area.
3611 The first argument is a format control string, and the rest are data
3612 to be formatted under control of the string. See `format' for details.
3614 If the first argument is nil or the empty string, clear any existing
3615 message; let the minibuffer contents show.
3617 usage: (message-box FORMAT-STRING &rest ARGS) */)
3618 (ptrdiff_t nargs, Lisp_Object *args)
3620 if (NILP (args[0]))
3622 message1 (0);
3623 return Qnil;
3625 else
3627 Lisp_Object val = Fformat (nargs, args);
3628 Lisp_Object pane, menu;
3629 struct gcpro gcpro1;
3631 pane = list1 (Fcons (build_string ("OK"), Qt));
3632 GCPRO1 (pane);
3633 menu = Fcons (val, pane);
3634 Fx_popup_dialog (Qt, menu, Qt);
3635 UNGCPRO;
3636 return val;
3640 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
3641 doc: /* Display a message in a dialog box or in the echo area.
3642 If this command was invoked with the mouse, use a dialog box if
3643 `use-dialog-box' is non-nil.
3644 Otherwise, use the echo area.
3645 The first argument is a format control string, and the rest are data
3646 to be formatted under control of the string. See `format' for details.
3648 If the first argument is nil or the empty string, clear any existing
3649 message; let the minibuffer contents show.
3651 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3652 (ptrdiff_t nargs, Lisp_Object *args)
3654 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
3655 && use_dialog_box)
3656 return Fmessage_box (nargs, args);
3657 return Fmessage (nargs, args);
3660 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
3661 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
3662 (void)
3664 return current_message ();
3668 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
3669 doc: /* Return a copy of STRING with text properties added.
3670 First argument is the string to copy.
3671 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3672 properties to add to the result.
3673 usage: (propertize STRING &rest PROPERTIES) */)
3674 (ptrdiff_t nargs, Lisp_Object *args)
3676 Lisp_Object properties, string;
3677 struct gcpro gcpro1, gcpro2;
3678 ptrdiff_t i;
3680 /* Number of args must be odd. */
3681 if ((nargs & 1) == 0)
3682 error ("Wrong number of arguments");
3684 properties = string = Qnil;
3685 GCPRO2 (properties, string);
3687 /* First argument must be a string. */
3688 CHECK_STRING (args[0]);
3689 string = Fcopy_sequence (args[0]);
3691 for (i = 1; i < nargs; i += 2)
3692 properties = Fcons (args[i], Fcons (args[i + 1], properties));
3694 Fadd_text_properties (make_number (0),
3695 make_number (SCHARS (string)),
3696 properties, string);
3697 RETURN_UNGCPRO (string);
3700 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
3701 doc: /* Format a string out of a format-string and arguments.
3702 The first argument is a format control string.
3703 The other arguments are substituted into it to make the result, a string.
3705 The format control string may contain %-sequences meaning to substitute
3706 the next available argument:
3708 %s means print a string argument. Actually, prints any object, with `princ'.
3709 %d means print as number in decimal (%o octal, %x hex).
3710 %X is like %x, but uses upper case.
3711 %e means print a number in exponential notation.
3712 %f means print a number in decimal-point notation.
3713 %g means print a number in exponential notation
3714 or decimal-point notation, whichever uses fewer characters.
3715 %c means print a number as a single character.
3716 %S means print any object as an s-expression (using `prin1').
3718 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3719 Use %% to put a single % into the output.
3721 A %-sequence may contain optional flag, width, and precision
3722 specifiers, as follows:
3724 %<flags><width><precision>character
3726 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3728 The + flag character inserts a + before any positive number, while a
3729 space inserts a space before any positive number; these flags only
3730 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3731 The - and 0 flags affect the width specifier, as described below.
3733 The # flag means to use an alternate display form for %o, %x, %X, %e,
3734 %f, and %g sequences: for %o, it ensures that the result begins with
3735 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3736 for %e, %f, and %g, it causes a decimal point to be included even if
3737 the precision is zero.
3739 The width specifier supplies a lower limit for the length of the
3740 printed representation. The padding, if any, normally goes on the
3741 left, but it goes on the right if the - flag is present. The padding
3742 character is normally a space, but it is 0 if the 0 flag is present.
3743 The 0 flag is ignored if the - flag is present, or the format sequence
3744 is something other than %d, %e, %f, and %g.
3746 For %e, %f, and %g sequences, the number after the "." in the
3747 precision specifier says how many decimal places to show; if zero, the
3748 decimal point itself is omitted. For %s and %S, the precision
3749 specifier truncates the string to the given width.
3751 usage: (format STRING &rest OBJECTS) */)
3752 (ptrdiff_t nargs, Lisp_Object *args)
3754 ptrdiff_t n; /* The number of the next arg to substitute. */
3755 char initial_buffer[4000];
3756 char *buf = initial_buffer;
3757 ptrdiff_t bufsize = sizeof initial_buffer;
3758 ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1;
3759 char *p;
3760 ptrdiff_t buf_save_value_index IF_LINT (= 0);
3761 char *format, *end, *format_start;
3762 ptrdiff_t formatlen, nchars;
3763 /* True if the format is multibyte. */
3764 bool multibyte_format = 0;
3765 /* True if the output should be a multibyte string,
3766 which is true if any of the inputs is one. */
3767 bool multibyte = 0;
3768 /* When we make a multibyte string, we must pay attention to the
3769 byte combining problem, i.e., a byte may be combined with a
3770 multibyte character of the previous string. This flag tells if we
3771 must consider such a situation or not. */
3772 bool maybe_combine_byte;
3773 Lisp_Object val;
3774 bool arg_intervals = 0;
3775 USE_SAFE_ALLOCA;
3777 /* discarded[I] is 1 if byte I of the format
3778 string was not copied into the output.
3779 It is 2 if byte I was not the first byte of its character. */
3780 char *discarded;
3782 /* Each element records, for one argument,
3783 the start and end bytepos in the output string,
3784 whether the argument has been converted to string (e.g., due to "%S"),
3785 and whether the argument is a string with intervals.
3786 info[0] is unused. Unused elements have -1 for start. */
3787 struct info
3789 ptrdiff_t start, end;
3790 bool_bf converted_to_string : 1;
3791 bool_bf intervals : 1;
3792 } *info = 0;
3794 /* It should not be necessary to GCPRO ARGS, because
3795 the caller in the interpreter should take care of that. */
3797 CHECK_STRING (args[0]);
3798 format_start = SSDATA (args[0]);
3799 formatlen = SBYTES (args[0]);
3801 /* Allocate the info and discarded tables. */
3803 ptrdiff_t i;
3804 if ((SIZE_MAX - formatlen) / sizeof (struct info) <= nargs)
3805 memory_full (SIZE_MAX);
3806 info = SAFE_ALLOCA ((nargs + 1) * sizeof *info + formatlen);
3807 discarded = (char *) &info[nargs + 1];
3808 for (i = 0; i < nargs + 1; i++)
3810 info[i].start = -1;
3811 info[i].intervals = info[i].converted_to_string = 0;
3813 memset (discarded, 0, formatlen);
3816 /* Try to determine whether the result should be multibyte.
3817 This is not always right; sometimes the result needs to be multibyte
3818 because of an object that we will pass through prin1,
3819 and in that case, we won't know it here. */
3820 multibyte_format = STRING_MULTIBYTE (args[0]);
3821 multibyte = multibyte_format;
3822 for (n = 1; !multibyte && n < nargs; n++)
3823 if (STRINGP (args[n]) && STRING_MULTIBYTE (args[n]))
3824 multibyte = 1;
3826 /* If we start out planning a unibyte result,
3827 then discover it has to be multibyte, we jump back to retry. */
3828 retry:
3830 p = buf;
3831 nchars = 0;
3832 n = 0;
3834 /* Scan the format and store result in BUF. */
3835 format = format_start;
3836 end = format + formatlen;
3837 maybe_combine_byte = 0;
3839 while (format != end)
3841 /* The values of N and FORMAT when the loop body is entered. */
3842 ptrdiff_t n0 = n;
3843 char *format0 = format;
3845 /* Bytes needed to represent the output of this conversion. */
3846 ptrdiff_t convbytes;
3848 if (*format == '%')
3850 /* General format specifications look like
3852 '%' [flags] [field-width] [precision] format
3854 where
3856 flags ::= [-+0# ]+
3857 field-width ::= [0-9]+
3858 precision ::= '.' [0-9]*
3860 If a field-width is specified, it specifies to which width
3861 the output should be padded with blanks, if the output
3862 string is shorter than field-width.
3864 If precision is specified, it specifies the number of
3865 digits to print after the '.' for floats, or the max.
3866 number of chars to print from a string. */
3868 bool minus_flag = 0;
3869 bool plus_flag = 0;
3870 bool space_flag = 0;
3871 bool sharp_flag = 0;
3872 bool zero_flag = 0;
3873 ptrdiff_t field_width;
3874 bool precision_given;
3875 uintmax_t precision = UINTMAX_MAX;
3876 char *num_end;
3877 char conversion;
3879 while (1)
3881 switch (*++format)
3883 case '-': minus_flag = 1; continue;
3884 case '+': plus_flag = 1; continue;
3885 case ' ': space_flag = 1; continue;
3886 case '#': sharp_flag = 1; continue;
3887 case '0': zero_flag = 1; continue;
3889 break;
3892 /* Ignore flags when sprintf ignores them. */
3893 space_flag &= ~ plus_flag;
3894 zero_flag &= ~ minus_flag;
3897 uintmax_t w = strtoumax (format, &num_end, 10);
3898 if (max_bufsize <= w)
3899 string_overflow ();
3900 field_width = w;
3902 precision_given = *num_end == '.';
3903 if (precision_given)
3904 precision = strtoumax (num_end + 1, &num_end, 10);
3905 format = num_end;
3907 if (format == end)
3908 error ("Format string ends in middle of format specifier");
3910 memset (&discarded[format0 - format_start], 1, format - format0);
3911 conversion = *format;
3912 if (conversion == '%')
3913 goto copy_char;
3914 discarded[format - format_start] = 1;
3915 format++;
3917 ++n;
3918 if (! (n < nargs))
3919 error ("Not enough arguments for format string");
3921 /* For 'S', prin1 the argument, and then treat like 's'.
3922 For 's', princ any argument that is not a string or
3923 symbol. But don't do this conversion twice, which might
3924 happen after retrying. */
3925 if ((conversion == 'S'
3926 || (conversion == 's'
3927 && ! STRINGP (args[n]) && ! SYMBOLP (args[n]))))
3929 if (! info[n].converted_to_string)
3931 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
3932 args[n] = Fprin1_to_string (args[n], noescape);
3933 info[n].converted_to_string = 1;
3934 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
3936 multibyte = 1;
3937 goto retry;
3940 conversion = 's';
3942 else if (conversion == 'c')
3944 if (FLOATP (args[n]))
3946 double d = XFLOAT_DATA (args[n]);
3947 args[n] = make_number (FIXNUM_OVERFLOW_P (d) ? -1 : d);
3950 if (INTEGERP (args[n]) && ! ASCII_CHAR_P (XINT (args[n])))
3952 if (!multibyte)
3954 multibyte = 1;
3955 goto retry;
3957 args[n] = Fchar_to_string (args[n]);
3958 info[n].converted_to_string = 1;
3961 if (info[n].converted_to_string)
3962 conversion = 's';
3963 zero_flag = 0;
3966 if (SYMBOLP (args[n]))
3968 args[n] = SYMBOL_NAME (args[n]);
3969 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
3971 multibyte = 1;
3972 goto retry;
3976 if (conversion == 's')
3978 /* handle case (precision[n] >= 0) */
3980 ptrdiff_t width, padding, nbytes;
3981 ptrdiff_t nchars_string;
3983 ptrdiff_t prec = -1;
3984 if (precision_given && precision <= TYPE_MAXIMUM (ptrdiff_t))
3985 prec = precision;
3987 /* lisp_string_width ignores a precision of 0, but GNU
3988 libc functions print 0 characters when the precision
3989 is 0. Imitate libc behavior here. Changing
3990 lisp_string_width is the right thing, and will be
3991 done, but meanwhile we work with it. */
3993 if (prec == 0)
3994 width = nchars_string = nbytes = 0;
3995 else
3997 ptrdiff_t nch, nby;
3998 width = lisp_string_width (args[n], prec, &nch, &nby);
3999 if (prec < 0)
4001 nchars_string = SCHARS (args[n]);
4002 nbytes = SBYTES (args[n]);
4004 else
4006 nchars_string = nch;
4007 nbytes = nby;
4011 convbytes = nbytes;
4012 if (convbytes && multibyte && ! STRING_MULTIBYTE (args[n]))
4013 convbytes = count_size_as_multibyte (SDATA (args[n]), nbytes);
4015 padding = width < field_width ? field_width - width : 0;
4017 if (max_bufsize - padding <= convbytes)
4018 string_overflow ();
4019 convbytes += padding;
4020 if (convbytes <= buf + bufsize - p)
4022 if (! minus_flag)
4024 memset (p, ' ', padding);
4025 p += padding;
4026 nchars += padding;
4029 if (p > buf
4030 && multibyte
4031 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
4032 && STRING_MULTIBYTE (args[n])
4033 && !CHAR_HEAD_P (SREF (args[n], 0)))
4034 maybe_combine_byte = 1;
4036 p += copy_text (SDATA (args[n]), (unsigned char *) p,
4037 nbytes,
4038 STRING_MULTIBYTE (args[n]), multibyte);
4040 info[n].start = nchars;
4041 nchars += nchars_string;
4042 info[n].end = nchars;
4044 if (minus_flag)
4046 memset (p, ' ', padding);
4047 p += padding;
4048 nchars += padding;
4051 /* If this argument has text properties, record where
4052 in the result string it appears. */
4053 if (string_intervals (args[n]))
4054 info[n].intervals = arg_intervals = 1;
4056 continue;
4059 else if (! (conversion == 'c' || conversion == 'd'
4060 || conversion == 'e' || conversion == 'f'
4061 || conversion == 'g' || conversion == 'i'
4062 || conversion == 'o' || conversion == 'x'
4063 || conversion == 'X'))
4064 error ("Invalid format operation %%%c",
4065 STRING_CHAR ((unsigned char *) format - 1));
4066 else if (! (INTEGERP (args[n]) || FLOATP (args[n])))
4067 error ("Format specifier doesn't match argument type");
4068 else
4070 enum
4072 /* Maximum precision for a %f conversion such that the
4073 trailing output digit might be nonzero. Any precision
4074 larger than this will not yield useful information. */
4075 USEFUL_PRECISION_MAX =
4076 ((1 - DBL_MIN_EXP)
4077 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
4078 : FLT_RADIX == 16 ? 4
4079 : -1)),
4081 /* Maximum number of bytes generated by any format, if
4082 precision is no more than USEFUL_PRECISION_MAX.
4083 On all practical hosts, %f is the worst case. */
4084 SPRINTF_BUFSIZE =
4085 sizeof "-." + (DBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX,
4087 /* Length of pM (that is, of pMd without the
4088 trailing "d"). */
4089 pMlen = sizeof pMd - 2
4091 verify (USEFUL_PRECISION_MAX > 0);
4093 int prec;
4094 ptrdiff_t padding, sprintf_bytes;
4095 uintmax_t excess_precision, numwidth;
4096 uintmax_t leading_zeros = 0, trailing_zeros = 0;
4098 char sprintf_buf[SPRINTF_BUFSIZE];
4100 /* Copy of conversion specification, modified somewhat.
4101 At most three flags F can be specified at once. */
4102 char convspec[sizeof "%FFF.*d" + pMlen];
4104 /* Avoid undefined behavior in underlying sprintf. */
4105 if (conversion == 'd' || conversion == 'i')
4106 sharp_flag = 0;
4108 /* Create the copy of the conversion specification, with
4109 any width and precision removed, with ".*" inserted,
4110 and with pM inserted for integer formats. */
4112 char *f = convspec;
4113 *f++ = '%';
4114 *f = '-'; f += minus_flag;
4115 *f = '+'; f += plus_flag;
4116 *f = ' '; f += space_flag;
4117 *f = '#'; f += sharp_flag;
4118 *f = '0'; f += zero_flag;
4119 *f++ = '.';
4120 *f++ = '*';
4121 if (conversion == 'd' || conversion == 'i'
4122 || conversion == 'o' || conversion == 'x'
4123 || conversion == 'X')
4125 memcpy (f, pMd, pMlen);
4126 f += pMlen;
4127 zero_flag &= ~ precision_given;
4129 *f++ = conversion;
4130 *f = '\0';
4133 prec = -1;
4134 if (precision_given)
4135 prec = min (precision, USEFUL_PRECISION_MAX);
4137 /* Use sprintf to format this number into sprintf_buf. Omit
4138 padding and excess precision, though, because sprintf limits
4139 output length to INT_MAX.
4141 There are four types of conversion: double, unsigned
4142 char (passed as int), wide signed int, and wide
4143 unsigned int. Treat them separately because the
4144 sprintf ABI is sensitive to which type is passed. Be
4145 careful about integer overflow, NaNs, infinities, and
4146 conversions; for example, the min and max macros are
4147 not suitable here. */
4148 if (conversion == 'e' || conversion == 'f' || conversion == 'g')
4150 double x = (INTEGERP (args[n])
4151 ? XINT (args[n])
4152 : XFLOAT_DATA (args[n]));
4153 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4155 else if (conversion == 'c')
4157 /* Don't use sprintf here, as it might mishandle prec. */
4158 sprintf_buf[0] = XINT (args[n]);
4159 sprintf_bytes = prec != 0;
4161 else if (conversion == 'd')
4163 /* For float, maybe we should use "%1.0f"
4164 instead so it also works for values outside
4165 the integer range. */
4166 printmax_t x;
4167 if (INTEGERP (args[n]))
4168 x = XINT (args[n]);
4169 else
4171 double d = XFLOAT_DATA (args[n]);
4172 if (d < 0)
4174 x = TYPE_MINIMUM (printmax_t);
4175 if (x < d)
4176 x = d;
4178 else
4180 x = TYPE_MAXIMUM (printmax_t);
4181 if (d < x)
4182 x = d;
4185 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4187 else
4189 /* Don't sign-extend for octal or hex printing. */
4190 uprintmax_t x;
4191 if (INTEGERP (args[n]))
4192 x = XUINT (args[n]);
4193 else
4195 double d = XFLOAT_DATA (args[n]);
4196 if (d < 0)
4197 x = 0;
4198 else
4200 x = TYPE_MAXIMUM (uprintmax_t);
4201 if (d < x)
4202 x = d;
4205 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4208 /* Now the length of the formatted item is known, except it omits
4209 padding and excess precision. Deal with excess precision
4210 first. This happens only when the format specifies
4211 ridiculously large precision. */
4212 excess_precision = precision - prec;
4213 if (excess_precision)
4215 if (conversion == 'e' || conversion == 'f'
4216 || conversion == 'g')
4218 if ((conversion == 'g' && ! sharp_flag)
4219 || ! ('0' <= sprintf_buf[sprintf_bytes - 1]
4220 && sprintf_buf[sprintf_bytes - 1] <= '9'))
4221 excess_precision = 0;
4222 else
4224 if (conversion == 'g')
4226 char *dot = strchr (sprintf_buf, '.');
4227 if (!dot)
4228 excess_precision = 0;
4231 trailing_zeros = excess_precision;
4233 else
4234 leading_zeros = excess_precision;
4237 /* Compute the total bytes needed for this item, including
4238 excess precision and padding. */
4239 numwidth = sprintf_bytes + excess_precision;
4240 padding = numwidth < field_width ? field_width - numwidth : 0;
4241 if (max_bufsize - sprintf_bytes <= excess_precision
4242 || max_bufsize - padding <= numwidth)
4243 string_overflow ();
4244 convbytes = numwidth + padding;
4246 if (convbytes <= buf + bufsize - p)
4248 /* Copy the formatted item from sprintf_buf into buf,
4249 inserting padding and excess-precision zeros. */
4251 char *src = sprintf_buf;
4252 char src0 = src[0];
4253 int exponent_bytes = 0;
4254 bool signedp = src0 == '-' || src0 == '+' || src0 == ' ';
4255 int significand_bytes;
4256 if (zero_flag
4257 && ((src[signedp] >= '0' && src[signedp] <= '9')
4258 || (src[signedp] >= 'a' && src[signedp] <= 'f')
4259 || (src[signedp] >= 'A' && src[signedp] <= 'F')))
4261 leading_zeros += padding;
4262 padding = 0;
4265 if (excess_precision
4266 && (conversion == 'e' || conversion == 'g'))
4268 char *e = strchr (src, 'e');
4269 if (e)
4270 exponent_bytes = src + sprintf_bytes - e;
4273 if (! minus_flag)
4275 memset (p, ' ', padding);
4276 p += padding;
4277 nchars += padding;
4280 *p = src0;
4281 src += signedp;
4282 p += signedp;
4283 memset (p, '0', leading_zeros);
4284 p += leading_zeros;
4285 significand_bytes = sprintf_bytes - signedp - exponent_bytes;
4286 memcpy (p, src, significand_bytes);
4287 p += significand_bytes;
4288 src += significand_bytes;
4289 memset (p, '0', trailing_zeros);
4290 p += trailing_zeros;
4291 memcpy (p, src, exponent_bytes);
4292 p += exponent_bytes;
4294 info[n].start = nchars;
4295 nchars += leading_zeros + sprintf_bytes + trailing_zeros;
4296 info[n].end = nchars;
4298 if (minus_flag)
4300 memset (p, ' ', padding);
4301 p += padding;
4302 nchars += padding;
4305 continue;
4309 else
4310 copy_char:
4312 /* Copy a single character from format to buf. */
4314 char *src = format;
4315 unsigned char str[MAX_MULTIBYTE_LENGTH];
4317 if (multibyte_format)
4319 /* Copy a whole multibyte character. */
4320 if (p > buf
4321 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
4322 && !CHAR_HEAD_P (*format))
4323 maybe_combine_byte = 1;
4326 format++;
4327 while (! CHAR_HEAD_P (*format));
4329 convbytes = format - src;
4330 memset (&discarded[src + 1 - format_start], 2, convbytes - 1);
4332 else
4334 unsigned char uc = *format++;
4335 if (! multibyte || ASCII_CHAR_P (uc))
4336 convbytes = 1;
4337 else
4339 int c = BYTE8_TO_CHAR (uc);
4340 convbytes = CHAR_STRING (c, str);
4341 src = (char *) str;
4345 if (convbytes <= buf + bufsize - p)
4347 memcpy (p, src, convbytes);
4348 p += convbytes;
4349 nchars++;
4350 continue;
4354 /* There wasn't enough room to store this conversion or single
4355 character. CONVBYTES says how much room is needed. Allocate
4356 enough room (and then some) and do it again. */
4358 ptrdiff_t used = p - buf;
4360 if (max_bufsize - used < convbytes)
4361 string_overflow ();
4362 bufsize = used + convbytes;
4363 bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize;
4365 if (buf == initial_buffer)
4367 buf = xmalloc (bufsize);
4368 sa_must_free = true;
4369 buf_save_value_index = SPECPDL_INDEX ();
4370 record_unwind_protect_ptr (xfree, buf);
4371 memcpy (buf, initial_buffer, used);
4373 else
4375 buf = xrealloc (buf, bufsize);
4376 set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
4379 p = buf + used;
4382 format = format0;
4383 n = n0;
4386 if (bufsize < p - buf)
4387 emacs_abort ();
4389 if (maybe_combine_byte)
4390 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf);
4391 val = make_specified_string (buf, nchars, p - buf, multibyte);
4393 /* If we allocated BUF with malloc, free it too. */
4394 SAFE_FREE ();
4396 /* If the format string has text properties, or any of the string
4397 arguments has text properties, set up text properties of the
4398 result string. */
4400 if (string_intervals (args[0]) || arg_intervals)
4402 Lisp_Object len, new_len, props;
4403 struct gcpro gcpro1;
4405 /* Add text properties from the format string. */
4406 len = make_number (SCHARS (args[0]));
4407 props = text_property_list (args[0], make_number (0), len, Qnil);
4408 GCPRO1 (props);
4410 if (CONSP (props))
4412 ptrdiff_t bytepos = 0, position = 0, translated = 0;
4413 ptrdiff_t argn = 1;
4414 Lisp_Object list;
4416 /* Adjust the bounds of each text property
4417 to the proper start and end in the output string. */
4419 /* Put the positions in PROPS in increasing order, so that
4420 we can do (effectively) one scan through the position
4421 space of the format string. */
4422 props = Fnreverse (props);
4424 /* BYTEPOS is the byte position in the format string,
4425 POSITION is the untranslated char position in it,
4426 TRANSLATED is the translated char position in BUF,
4427 and ARGN is the number of the next arg we will come to. */
4428 for (list = props; CONSP (list); list = XCDR (list))
4430 Lisp_Object item;
4431 ptrdiff_t pos;
4433 item = XCAR (list);
4435 /* First adjust the property start position. */
4436 pos = XINT (XCAR (item));
4438 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4439 up to this position. */
4440 for (; position < pos; bytepos++)
4442 if (! discarded[bytepos])
4443 position++, translated++;
4444 else if (discarded[bytepos] == 1)
4446 position++;
4447 if (translated == info[argn].start)
4449 translated += info[argn].end - info[argn].start;
4450 argn++;
4455 XSETCAR (item, make_number (translated));
4457 /* Likewise adjust the property end position. */
4458 pos = XINT (XCAR (XCDR (item)));
4460 for (; position < pos; bytepos++)
4462 if (! discarded[bytepos])
4463 position++, translated++;
4464 else if (discarded[bytepos] == 1)
4466 position++;
4467 if (translated == info[argn].start)
4469 translated += info[argn].end - info[argn].start;
4470 argn++;
4475 XSETCAR (XCDR (item), make_number (translated));
4478 add_text_properties_from_list (val, props, make_number (0));
4481 /* Add text properties from arguments. */
4482 if (arg_intervals)
4483 for (n = 1; n < nargs; ++n)
4484 if (info[n].intervals)
4486 len = make_number (SCHARS (args[n]));
4487 new_len = make_number (info[n].end - info[n].start);
4488 props = text_property_list (args[n], make_number (0), len, Qnil);
4489 props = extend_property_ranges (props, new_len);
4490 /* If successive arguments have properties, be sure that
4491 the value of `composition' property be the copy. */
4492 if (n > 1 && info[n - 1].end)
4493 make_composition_value_copy (props);
4494 add_text_properties_from_list (val, props,
4495 make_number (info[n].start));
4498 UNGCPRO;
4501 return val;
4504 Lisp_Object
4505 format2 (const char *string1, Lisp_Object arg0, Lisp_Object arg1)
4507 AUTO_STRING (format, string1);
4508 return CALLN (Fformat, format, arg0, arg1);
4511 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
4512 doc: /* Return t if two characters match, optionally ignoring case.
4513 Both arguments must be characters (i.e. integers).
4514 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4515 (register Lisp_Object c1, Lisp_Object c2)
4517 int i1, i2;
4518 /* Check they're chars, not just integers, otherwise we could get array
4519 bounds violations in downcase. */
4520 CHECK_CHARACTER (c1);
4521 CHECK_CHARACTER (c2);
4523 if (XINT (c1) == XINT (c2))
4524 return Qt;
4525 if (NILP (BVAR (current_buffer, case_fold_search)))
4526 return Qnil;
4528 i1 = XFASTINT (c1);
4529 i2 = XFASTINT (c2);
4531 /* FIXME: It is possible to compare multibyte characters even when
4532 the current buffer is unibyte. Unfortunately this is ambiguous
4533 for characters between 128 and 255, as they could be either
4534 eight-bit raw bytes or Latin-1 characters. Assume the former for
4535 now. See Bug#17011, and also see casefiddle.c's casify_object,
4536 which has a similar problem. */
4537 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4539 if (SINGLE_BYTE_CHAR_P (i1))
4540 i1 = UNIBYTE_TO_CHAR (i1);
4541 if (SINGLE_BYTE_CHAR_P (i2))
4542 i2 = UNIBYTE_TO_CHAR (i2);
4545 return (downcase (i1) == downcase (i2) ? Qt : Qnil);
4548 /* Transpose the markers in two regions of the current buffer, and
4549 adjust the ones between them if necessary (i.e.: if the regions
4550 differ in size).
4552 START1, END1 are the character positions of the first region.
4553 START1_BYTE, END1_BYTE are the byte positions.
4554 START2, END2 are the character positions of the second region.
4555 START2_BYTE, END2_BYTE are the byte positions.
4557 Traverses the entire marker list of the buffer to do so, adding an
4558 appropriate amount to some, subtracting from some, and leaving the
4559 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4561 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4563 static void
4564 transpose_markers (ptrdiff_t start1, ptrdiff_t end1,
4565 ptrdiff_t start2, ptrdiff_t end2,
4566 ptrdiff_t start1_byte, ptrdiff_t end1_byte,
4567 ptrdiff_t start2_byte, ptrdiff_t end2_byte)
4569 register ptrdiff_t amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
4570 register struct Lisp_Marker *marker;
4572 /* Update point as if it were a marker. */
4573 if (PT < start1)
4575 else if (PT < end1)
4576 TEMP_SET_PT_BOTH (PT + (end2 - end1),
4577 PT_BYTE + (end2_byte - end1_byte));
4578 else if (PT < start2)
4579 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
4580 (PT_BYTE + (end2_byte - start2_byte)
4581 - (end1_byte - start1_byte)));
4582 else if (PT < end2)
4583 TEMP_SET_PT_BOTH (PT - (start2 - start1),
4584 PT_BYTE - (start2_byte - start1_byte));
4586 /* We used to adjust the endpoints here to account for the gap, but that
4587 isn't good enough. Even if we assume the caller has tried to move the
4588 gap out of our way, it might still be at start1 exactly, for example;
4589 and that places it `inside' the interval, for our purposes. The amount
4590 of adjustment is nontrivial if there's a `denormalized' marker whose
4591 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4592 the dirty work to Fmarker_position, below. */
4594 /* The difference between the region's lengths */
4595 diff = (end2 - start2) - (end1 - start1);
4596 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
4598 /* For shifting each marker in a region by the length of the other
4599 region plus the distance between the regions. */
4600 amt1 = (end2 - start2) + (start2 - end1);
4601 amt2 = (end1 - start1) + (start2 - end1);
4602 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
4603 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
4605 for (marker = BUF_MARKERS (current_buffer); marker; marker = marker->next)
4607 mpos = marker->bytepos;
4608 if (mpos >= start1_byte && mpos < end2_byte)
4610 if (mpos < end1_byte)
4611 mpos += amt1_byte;
4612 else if (mpos < start2_byte)
4613 mpos += diff_byte;
4614 else
4615 mpos -= amt2_byte;
4616 marker->bytepos = mpos;
4618 mpos = marker->charpos;
4619 if (mpos >= start1 && mpos < end2)
4621 if (mpos < end1)
4622 mpos += amt1;
4623 else if (mpos < start2)
4624 mpos += diff;
4625 else
4626 mpos -= amt2;
4628 marker->charpos = mpos;
4632 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
4633 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4634 The regions should not be overlapping, because the size of the buffer is
4635 never changed in a transposition.
4637 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4638 any markers that happen to be located in the regions.
4640 Transposing beyond buffer boundaries is an error. */)
4641 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
4643 register ptrdiff_t start1, end1, start2, end2;
4644 ptrdiff_t start1_byte, start2_byte, len1_byte, len2_byte, end2_byte;
4645 ptrdiff_t gap, len1, len_mid, len2;
4646 unsigned char *start1_addr, *start2_addr, *temp;
4648 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2, tmp_interval3;
4649 Lisp_Object buf;
4651 XSETBUFFER (buf, current_buffer);
4652 cur_intv = buffer_intervals (current_buffer);
4654 validate_region (&startr1, &endr1);
4655 validate_region (&startr2, &endr2);
4657 start1 = XFASTINT (startr1);
4658 end1 = XFASTINT (endr1);
4659 start2 = XFASTINT (startr2);
4660 end2 = XFASTINT (endr2);
4661 gap = GPT;
4663 /* Swap the regions if they're reversed. */
4664 if (start2 < end1)
4666 register ptrdiff_t glumph = start1;
4667 start1 = start2;
4668 start2 = glumph;
4669 glumph = end1;
4670 end1 = end2;
4671 end2 = glumph;
4674 len1 = end1 - start1;
4675 len2 = end2 - start2;
4677 if (start2 < end1)
4678 error ("Transposed regions overlap");
4679 /* Nothing to change for adjacent regions with one being empty */
4680 else if ((start1 == end1 || start2 == end2) && end1 == start2)
4681 return Qnil;
4683 /* The possibilities are:
4684 1. Adjacent (contiguous) regions, or separate but equal regions
4685 (no, really equal, in this case!), or
4686 2. Separate regions of unequal size.
4688 The worst case is usually No. 2. It means that (aside from
4689 potential need for getting the gap out of the way), there also
4690 needs to be a shifting of the text between the two regions. So
4691 if they are spread far apart, we are that much slower... sigh. */
4693 /* It must be pointed out that the really studly thing to do would
4694 be not to move the gap at all, but to leave it in place and work
4695 around it if necessary. This would be extremely efficient,
4696 especially considering that people are likely to do
4697 transpositions near where they are working interactively, which
4698 is exactly where the gap would be found. However, such code
4699 would be much harder to write and to read. So, if you are
4700 reading this comment and are feeling squirrely, by all means have
4701 a go! I just didn't feel like doing it, so I will simply move
4702 the gap the minimum distance to get it out of the way, and then
4703 deal with an unbroken array. */
4705 start1_byte = CHAR_TO_BYTE (start1);
4706 end2_byte = CHAR_TO_BYTE (end2);
4708 /* Make sure the gap won't interfere, by moving it out of the text
4709 we will operate on. */
4710 if (start1 < gap && gap < end2)
4712 if (gap - start1 < end2 - gap)
4713 move_gap_both (start1, start1_byte);
4714 else
4715 move_gap_both (end2, end2_byte);
4718 start2_byte = CHAR_TO_BYTE (start2);
4719 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
4720 len2_byte = end2_byte - start2_byte;
4722 #ifdef BYTE_COMBINING_DEBUG
4723 if (end1 == start2)
4725 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4726 len2_byte, start1, start1_byte)
4727 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4728 len1_byte, end2, start2_byte + len2_byte)
4729 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4730 len1_byte, end2, start2_byte + len2_byte))
4731 emacs_abort ();
4733 else
4735 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4736 len2_byte, start1, start1_byte)
4737 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4738 len1_byte, start2, start2_byte)
4739 || count_combining_after (BYTE_POS_ADDR (start2_byte),
4740 len2_byte, end1, start1_byte + len1_byte)
4741 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4742 len1_byte, end2, start2_byte + len2_byte))
4743 emacs_abort ();
4745 #endif
4747 /* Hmmm... how about checking to see if the gap is large
4748 enough to use as the temporary storage? That would avoid an
4749 allocation... interesting. Later, don't fool with it now. */
4751 /* Working without memmove, for portability (sigh), so must be
4752 careful of overlapping subsections of the array... */
4754 if (end1 == start2) /* adjacent regions */
4756 modify_text (start1, end2);
4757 record_change (start1, len1 + len2);
4759 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4760 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4761 /* Don't use Fset_text_properties: that can cause GC, which can
4762 clobber objects stored in the tmp_intervals. */
4763 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4764 if (tmp_interval3)
4765 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4767 USE_SAFE_ALLOCA;
4769 /* First region smaller than second. */
4770 if (len1_byte < len2_byte)
4772 temp = SAFE_ALLOCA (len2_byte);
4774 /* Don't precompute these addresses. We have to compute them
4775 at the last minute, because the relocating allocator might
4776 have moved the buffer around during the xmalloc. */
4777 start1_addr = BYTE_POS_ADDR (start1_byte);
4778 start2_addr = BYTE_POS_ADDR (start2_byte);
4780 memcpy (temp, start2_addr, len2_byte);
4781 memcpy (start1_addr + len2_byte, start1_addr, len1_byte);
4782 memcpy (start1_addr, temp, len2_byte);
4784 else
4785 /* First region not smaller than second. */
4787 temp = SAFE_ALLOCA (len1_byte);
4788 start1_addr = BYTE_POS_ADDR (start1_byte);
4789 start2_addr = BYTE_POS_ADDR (start2_byte);
4790 memcpy (temp, start1_addr, len1_byte);
4791 memcpy (start1_addr, start2_addr, len2_byte);
4792 memcpy (start1_addr + len2_byte, temp, len1_byte);
4795 SAFE_FREE ();
4796 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
4797 len1, current_buffer, 0);
4798 graft_intervals_into_buffer (tmp_interval2, start1,
4799 len2, current_buffer, 0);
4800 update_compositions (start1, start1 + len2, CHECK_BORDER);
4801 update_compositions (start1 + len2, end2, CHECK_TAIL);
4803 /* Non-adjacent regions, because end1 != start2, bleagh... */
4804 else
4806 len_mid = start2_byte - (start1_byte + len1_byte);
4808 if (len1_byte == len2_byte)
4809 /* Regions are same size, though, how nice. */
4811 USE_SAFE_ALLOCA;
4813 modify_text (start1, end1);
4814 modify_text (start2, end2);
4815 record_change (start1, len1);
4816 record_change (start2, len2);
4817 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4818 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4820 tmp_interval3 = validate_interval_range (buf, &startr1, &endr1, 0);
4821 if (tmp_interval3)
4822 set_text_properties_1 (startr1, endr1, Qnil, buf, tmp_interval3);
4824 tmp_interval3 = validate_interval_range (buf, &startr2, &endr2, 0);
4825 if (tmp_interval3)
4826 set_text_properties_1 (startr2, endr2, Qnil, buf, tmp_interval3);
4828 temp = SAFE_ALLOCA (len1_byte);
4829 start1_addr = BYTE_POS_ADDR (start1_byte);
4830 start2_addr = BYTE_POS_ADDR (start2_byte);
4831 memcpy (temp, start1_addr, len1_byte);
4832 memcpy (start1_addr, start2_addr, len2_byte);
4833 memcpy (start2_addr, temp, len1_byte);
4834 SAFE_FREE ();
4836 graft_intervals_into_buffer (tmp_interval1, start2,
4837 len1, current_buffer, 0);
4838 graft_intervals_into_buffer (tmp_interval2, start1,
4839 len2, current_buffer, 0);
4842 else if (len1_byte < len2_byte) /* Second region larger than first */
4843 /* Non-adjacent & unequal size, area between must also be shifted. */
4845 USE_SAFE_ALLOCA;
4847 modify_text (start1, end2);
4848 record_change (start1, (end2 - start1));
4849 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4850 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4851 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4853 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4854 if (tmp_interval3)
4855 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4857 /* holds region 2 */
4858 temp = SAFE_ALLOCA (len2_byte);
4859 start1_addr = BYTE_POS_ADDR (start1_byte);
4860 start2_addr = BYTE_POS_ADDR (start2_byte);
4861 memcpy (temp, start2_addr, len2_byte);
4862 memcpy (start1_addr + len_mid + len2_byte, start1_addr, len1_byte);
4863 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4864 memcpy (start1_addr, temp, len2_byte);
4865 SAFE_FREE ();
4867 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4868 len1, current_buffer, 0);
4869 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4870 len_mid, current_buffer, 0);
4871 graft_intervals_into_buffer (tmp_interval2, start1,
4872 len2, current_buffer, 0);
4874 else
4875 /* Second region smaller than first. */
4877 USE_SAFE_ALLOCA;
4879 record_change (start1, (end2 - start1));
4880 modify_text (start1, end2);
4882 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4883 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4884 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4886 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4887 if (tmp_interval3)
4888 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4890 /* holds region 1 */
4891 temp = SAFE_ALLOCA (len1_byte);
4892 start1_addr = BYTE_POS_ADDR (start1_byte);
4893 start2_addr = BYTE_POS_ADDR (start2_byte);
4894 memcpy (temp, start1_addr, len1_byte);
4895 memcpy (start1_addr, start2_addr, len2_byte);
4896 memcpy (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4897 memcpy (start1_addr + len2_byte + len_mid, temp, len1_byte);
4898 SAFE_FREE ();
4900 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4901 len1, current_buffer, 0);
4902 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4903 len_mid, current_buffer, 0);
4904 graft_intervals_into_buffer (tmp_interval2, start1,
4905 len2, current_buffer, 0);
4908 update_compositions (start1, start1 + len2, CHECK_BORDER);
4909 update_compositions (end2 - len1, end2, CHECK_BORDER);
4912 /* When doing multiple transpositions, it might be nice
4913 to optimize this. Perhaps the markers in any one buffer
4914 should be organized in some sorted data tree. */
4915 if (NILP (leave_markers))
4917 transpose_markers (start1, end1, start2, end2,
4918 start1_byte, start1_byte + len1_byte,
4919 start2_byte, start2_byte + len2_byte);
4920 fix_start_end_in_overlays (start1, end2);
4923 signal_after_change (start1, end2 - start1, end2 - start1);
4924 return Qnil;
4928 void
4929 syms_of_editfns (void)
4931 DEFSYM (Qbuffer_access_fontify_functions, "buffer-access-fontify-functions");
4933 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
4934 doc: /* Non-nil means text motion commands don't notice fields. */);
4935 Vinhibit_field_text_motion = Qnil;
4937 DEFVAR_LISP ("buffer-access-fontify-functions",
4938 Vbuffer_access_fontify_functions,
4939 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
4940 Each function is called with two arguments which specify the range
4941 of the buffer being accessed. */);
4942 Vbuffer_access_fontify_functions = Qnil;
4945 Lisp_Object obuf;
4946 obuf = Fcurrent_buffer ();
4947 /* Do this here, because init_buffer_once is too early--it won't work. */
4948 Fset_buffer (Vprin1_to_string_buffer);
4949 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4950 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions), Qnil);
4951 Fset_buffer (obuf);
4954 DEFVAR_LISP ("buffer-access-fontified-property",
4955 Vbuffer_access_fontified_property,
4956 doc: /* Property which (if non-nil) indicates text has been fontified.
4957 `buffer-substring' need not call the `buffer-access-fontify-functions'
4958 functions if all the text being accessed has this property. */);
4959 Vbuffer_access_fontified_property = Qnil;
4961 DEFVAR_LISP ("system-name", Vsystem_name,
4962 doc: /* The host name of the machine Emacs is running on. */);
4963 Vsystem_name = cached_system_name = Qnil;
4965 DEFVAR_LISP ("user-full-name", Vuser_full_name,
4966 doc: /* The full name of the user logged in. */);
4968 DEFVAR_LISP ("user-login-name", Vuser_login_name,
4969 doc: /* The user's name, taken from environment variables if possible. */);
4970 Vuser_login_name = Qnil;
4972 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name,
4973 doc: /* The user's name, based upon the real uid only. */);
4975 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
4976 doc: /* The release of the operating system Emacs is running on. */);
4978 defsubr (&Spropertize);
4979 defsubr (&Schar_equal);
4980 defsubr (&Sgoto_char);
4981 defsubr (&Sstring_to_char);
4982 defsubr (&Schar_to_string);
4983 defsubr (&Sbyte_to_string);
4984 defsubr (&Sbuffer_substring);
4985 defsubr (&Sbuffer_substring_no_properties);
4986 defsubr (&Sbuffer_string);
4987 defsubr (&Sget_pos_property);
4989 defsubr (&Spoint_marker);
4990 defsubr (&Smark_marker);
4991 defsubr (&Spoint);
4992 defsubr (&Sregion_beginning);
4993 defsubr (&Sregion_end);
4995 /* Symbol for the text property used to mark fields. */
4996 DEFSYM (Qfield, "field");
4998 /* A special value for Qfield properties. */
4999 DEFSYM (Qboundary, "boundary");
5001 defsubr (&Sfield_beginning);
5002 defsubr (&Sfield_end);
5003 defsubr (&Sfield_string);
5004 defsubr (&Sfield_string_no_properties);
5005 defsubr (&Sdelete_field);
5006 defsubr (&Sconstrain_to_field);
5008 defsubr (&Sline_beginning_position);
5009 defsubr (&Sline_end_position);
5011 defsubr (&Ssave_excursion);
5012 defsubr (&Ssave_current_buffer);
5014 defsubr (&Sbuffer_size);
5015 defsubr (&Spoint_max);
5016 defsubr (&Spoint_min);
5017 defsubr (&Spoint_min_marker);
5018 defsubr (&Spoint_max_marker);
5019 defsubr (&Sgap_position);
5020 defsubr (&Sgap_size);
5021 defsubr (&Sposition_bytes);
5022 defsubr (&Sbyte_to_position);
5024 defsubr (&Sbobp);
5025 defsubr (&Seobp);
5026 defsubr (&Sbolp);
5027 defsubr (&Seolp);
5028 defsubr (&Sfollowing_char);
5029 defsubr (&Sprevious_char);
5030 defsubr (&Schar_after);
5031 defsubr (&Schar_before);
5032 defsubr (&Sinsert);
5033 defsubr (&Sinsert_before_markers);
5034 defsubr (&Sinsert_and_inherit);
5035 defsubr (&Sinsert_and_inherit_before_markers);
5036 defsubr (&Sinsert_char);
5037 defsubr (&Sinsert_byte);
5039 defsubr (&Suser_login_name);
5040 defsubr (&Suser_real_login_name);
5041 defsubr (&Suser_uid);
5042 defsubr (&Suser_real_uid);
5043 defsubr (&Sgroup_gid);
5044 defsubr (&Sgroup_real_gid);
5045 defsubr (&Suser_full_name);
5046 defsubr (&Semacs_pid);
5047 defsubr (&Scurrent_time);
5048 defsubr (&Stime_add);
5049 defsubr (&Stime_subtract);
5050 defsubr (&Stime_less_p);
5051 defsubr (&Sget_internal_run_time);
5052 defsubr (&Sformat_time_string);
5053 defsubr (&Sfloat_time);
5054 defsubr (&Sdecode_time);
5055 defsubr (&Sencode_time);
5056 defsubr (&Scurrent_time_string);
5057 defsubr (&Scurrent_time_zone);
5058 defsubr (&Sset_time_zone_rule);
5059 defsubr (&Ssystem_name);
5060 defsubr (&Smessage);
5061 defsubr (&Smessage_box);
5062 defsubr (&Smessage_or_box);
5063 defsubr (&Scurrent_message);
5064 defsubr (&Sformat);
5066 defsubr (&Sinsert_buffer_substring);
5067 defsubr (&Scompare_buffer_substrings);
5068 defsubr (&Ssubst_char_in_region);
5069 defsubr (&Stranslate_region_internal);
5070 defsubr (&Sdelete_region);
5071 defsubr (&Sdelete_and_extract_region);
5072 defsubr (&Swiden);
5073 defsubr (&Snarrow_to_region);
5074 defsubr (&Ssave_restriction);
5075 defsubr (&Stranspose_regions);