Rationalize the use of c-new-BEG and c-new-END in CC Mode.
[emacs.git] / src / editfns.c
blob6b0996d65eb8dbd40838d0157d4c0f47cc2de3c3
1 /* Lisp functions pertaining to editing. -*- coding: utf-8 -*-
3 Copyright (C) 1985-1987, 1989, 1993-2016 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 (at
10 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 <errno.h>
48 #include <float.h>
49 #include <limits.h>
51 #include <intprops.h>
52 #include <strftime.h>
53 #include <verify.h>
55 #include "composite.h"
56 #include "intervals.h"
57 #include "character.h"
58 #include "buffer.h"
59 #include "coding.h"
60 #include "window.h"
61 #include "blockinput.h"
63 #define TM_YEAR_BASE 1900
65 #ifdef WINDOWSNT
66 extern Lisp_Object w32_get_internal_run_time (void);
67 #endif
69 static struct lisp_time lisp_time_struct (Lisp_Object, int *);
70 static Lisp_Object format_time_string (char const *, ptrdiff_t, struct timespec,
71 Lisp_Object, struct tm *);
72 static long int tm_gmtoff (struct tm *);
73 static int tm_diff (struct tm *, struct tm *);
74 static void update_buffer_properties (ptrdiff_t, ptrdiff_t);
75 static Lisp_Object styled_format (ptrdiff_t, Lisp_Object *, bool);
77 #ifndef HAVE_TM_GMTOFF
78 # define HAVE_TM_GMTOFF false
79 #endif
81 enum { tzeqlen = sizeof "TZ=" - 1 };
83 /* Time zones equivalent to current local time, to wall clock time,
84 and to UTC, respectively. */
85 static timezone_t local_tz;
86 static timezone_t wall_clock_tz;
87 static timezone_t const utc_tz = 0;
89 /* A valid but unlikely setting for the TZ environment variable.
90 It is OK (though a bit slower) if the user chooses this value. */
91 static char dump_tz_string[] = "TZ=UtC0";
93 /* The cached value of Vsystem_name. This is used only to compare it
94 to Vsystem_name, so it need not be visible to the GC. */
95 static Lisp_Object cached_system_name;
97 static void
98 init_and_cache_system_name (void)
100 init_system_name ();
101 cached_system_name = Vsystem_name;
104 static struct tm *
105 emacs_localtime_rz (timezone_t tz, time_t const *t, struct tm *tm)
107 tm = localtime_rz (tz, t, tm);
108 if (!tm && errno == ENOMEM)
109 memory_full (SIZE_MAX);
110 return tm;
113 static time_t
114 emacs_mktime_z (timezone_t tz, struct tm *tm)
116 errno = 0;
117 time_t t = mktime_z (tz, tm);
118 if (t == (time_t) -1 && errno == ENOMEM)
119 memory_full (SIZE_MAX);
120 return t;
123 /* Allocate a timezone, signaling on failure. */
124 static timezone_t
125 xtzalloc (char const *name)
127 timezone_t tz = tzalloc (name);
128 if (!tz)
129 memory_full (SIZE_MAX);
130 return tz;
133 /* Free a timezone, except do not free the time zone for local time.
134 Freeing utc_tz is also a no-op. */
135 static void
136 xtzfree (timezone_t tz)
138 if (tz != local_tz)
139 tzfree (tz);
142 /* Convert the Lisp time zone rule ZONE to a timezone_t object.
143 The returned value either is 0, or is LOCAL_TZ, or is newly allocated.
144 If SETTZ, set Emacs local time to the time zone rule; otherwise,
145 the caller should eventually pass the returned value to xtzfree. */
146 static timezone_t
147 tzlookup (Lisp_Object zone, bool settz)
149 char const *zone_string;
150 timezone_t new_tz;
152 if (NILP (zone))
153 return local_tz;
154 else if (EQ (zone, Qt))
156 zone_string = "UTC0";
157 new_tz = utc_tz;
159 else
161 static char const tzbuf_format[] = "<%+.*"pI"d>%s%"pI"d:%02d:%02d";
162 char const *trailing_tzbuf_format = tzbuf_format + sizeof "<%+.*"pI"d" - 1;
163 char tzbuf[sizeof tzbuf_format + 2 * INT_STRLEN_BOUND (EMACS_INT)];
164 bool plain_integer = INTEGERP (zone);
166 if (EQ (zone, Qwall))
167 zone_string = 0;
168 else if (STRINGP (zone))
169 zone_string = SSDATA (ENCODE_SYSTEM (zone));
170 else if (plain_integer || (CONSP (zone) && INTEGERP (XCAR (zone))
171 && CONSP (XCDR (zone))))
173 Lisp_Object abbr;
174 if (!plain_integer)
176 abbr = XCAR (XCDR (zone));
177 zone = XCAR (zone);
180 EMACS_INT abszone = eabs (XINT (zone)), hour = abszone / (60 * 60);
181 int hour_remainder = abszone % (60 * 60);
182 int min = hour_remainder / 60, sec = hour_remainder % 60;
184 if (plain_integer)
186 int prec = 2;
187 EMACS_INT numzone = hour;
188 if (hour_remainder != 0)
190 prec += 2, numzone = 100 * numzone + min;
191 if (sec != 0)
192 prec += 2, numzone = 100 * numzone + sec;
194 sprintf (tzbuf, tzbuf_format, prec, numzone,
195 &"-"[XINT (zone) < 0], hour, min, sec);
196 zone_string = tzbuf;
198 else
200 AUTO_STRING (leading, "<");
201 AUTO_STRING_WITH_LEN (trailing, tzbuf,
202 sprintf (tzbuf, trailing_tzbuf_format,
203 &"-"[XINT (zone) < 0],
204 hour, min, sec));
205 zone_string = SSDATA (concat3 (leading, ENCODE_SYSTEM (abbr),
206 trailing));
209 else
210 xsignal2 (Qerror, build_string ("Invalid time zone specification"),
211 zone);
212 new_tz = xtzalloc (zone_string);
215 if (settz)
217 block_input ();
218 emacs_setenv_TZ (zone_string);
219 timezone_t old_tz = local_tz;
220 local_tz = new_tz;
221 tzfree (old_tz);
222 unblock_input ();
225 return new_tz;
228 void
229 init_editfns (bool dumping)
231 const char *user_name;
232 register char *p;
233 struct passwd *pw; /* password entry for the current user */
234 Lisp_Object tem;
236 /* Set up system_name even when dumping. */
237 init_and_cache_system_name ();
239 #ifndef CANNOT_DUMP
240 /* When just dumping out, set the time zone to a known unlikely value
241 and skip the rest of this function. */
242 if (dumping)
244 # ifdef HAVE_TZSET
245 xputenv (dump_tz_string);
246 tzset ();
247 # endif
248 return;
250 #endif
252 char *tz = getenv ("TZ");
254 #if !defined CANNOT_DUMP && defined HAVE_TZSET
255 /* If the execution TZ happens to be the same as the dump TZ,
256 change it to some other value and then change it back,
257 to force the underlying implementation to reload the TZ info.
258 This is needed on implementations that load TZ info from files,
259 since the TZ file contents may differ between dump and execution. */
260 if (tz && strcmp (tz, &dump_tz_string[tzeqlen]) == 0)
262 ++*tz;
263 tzset ();
264 --*tz;
266 #endif
268 /* Set the time zone rule now, so that the call to putenv is done
269 before multiple threads are active. */
270 wall_clock_tz = xtzalloc (0);
271 tzlookup (tz ? build_string (tz) : Qwall, true);
273 pw = getpwuid (getuid ());
274 #ifdef MSDOS
275 /* We let the real user name default to "root" because that's quite
276 accurate on MS-DOS and because it lets Emacs find the init file.
277 (The DVX libraries override the Djgpp libraries here.) */
278 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
279 #else
280 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
281 #endif
283 /* Get the effective user name, by consulting environment variables,
284 or the effective uid if those are unset. */
285 user_name = getenv ("LOGNAME");
286 if (!user_name)
287 #ifdef WINDOWSNT
288 user_name = getenv ("USERNAME"); /* it's USERNAME on NT */
289 #else /* WINDOWSNT */
290 user_name = getenv ("USER");
291 #endif /* WINDOWSNT */
292 if (!user_name)
294 pw = getpwuid (geteuid ());
295 user_name = pw ? pw->pw_name : "unknown";
297 Vuser_login_name = build_string (user_name);
299 /* If the user name claimed in the environment vars differs from
300 the real uid, use the claimed name to find the full name. */
301 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
302 if (! NILP (tem))
303 tem = Vuser_login_name;
304 else
306 uid_t euid = geteuid ();
307 tem = make_fixnum_or_float (euid);
309 Vuser_full_name = Fuser_full_name (tem);
311 p = getenv ("NAME");
312 if (p)
313 Vuser_full_name = build_string (p);
314 else if (NILP (Vuser_full_name))
315 Vuser_full_name = build_string ("unknown");
317 #ifdef HAVE_SYS_UTSNAME_H
319 struct utsname uts;
320 uname (&uts);
321 Voperating_system_release = build_string (uts.release);
323 #else
324 Voperating_system_release = Qnil;
325 #endif
328 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
329 doc: /* Convert arg CHAR to a string containing that character.
330 usage: (char-to-string CHAR) */)
331 (Lisp_Object character)
333 int c, len;
334 unsigned char str[MAX_MULTIBYTE_LENGTH];
336 CHECK_CHARACTER (character);
337 c = XFASTINT (character);
339 len = CHAR_STRING (c, str);
340 return make_string_from_bytes ((char *) str, 1, len);
343 DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
344 doc: /* Convert arg BYTE to a unibyte string containing that byte. */)
345 (Lisp_Object byte)
347 unsigned char b;
348 CHECK_NUMBER (byte);
349 if (XINT (byte) < 0 || XINT (byte) > 255)
350 error ("Invalid byte");
351 b = XINT (byte);
352 return make_string_from_bytes ((char *) &b, 1, 1);
355 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
356 doc: /* Return the first character in STRING. */)
357 (register Lisp_Object string)
359 register Lisp_Object val;
360 CHECK_STRING (string);
361 if (SCHARS (string))
363 if (STRING_MULTIBYTE (string))
364 XSETFASTINT (val, STRING_CHAR (SDATA (string)));
365 else
366 XSETFASTINT (val, SREF (string, 0));
368 else
369 XSETFASTINT (val, 0);
370 return val;
373 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
374 doc: /* Return value of point, as an integer.
375 Beginning of buffer is position (point-min). */)
376 (void)
378 Lisp_Object temp;
379 XSETFASTINT (temp, PT);
380 return temp;
383 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
384 doc: /* Return value of point, as a marker object. */)
385 (void)
387 return build_marker (current_buffer, PT, PT_BYTE);
390 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
391 doc: /* Set point to POSITION, a number or marker.
392 Beginning of buffer is position (point-min), end is (point-max).
394 The return value is POSITION. */)
395 (register Lisp_Object position)
397 if (MARKERP (position))
398 set_point_from_marker (position);
399 else if (INTEGERP (position))
400 SET_PT (clip_to_bounds (BEGV, XINT (position), ZV));
401 else
402 wrong_type_argument (Qinteger_or_marker_p, position);
403 return position;
407 /* Return the start or end position of the region.
408 BEGINNINGP means return the start.
409 If there is no region active, signal an error. */
411 static Lisp_Object
412 region_limit (bool beginningp)
414 Lisp_Object m;
416 if (!NILP (Vtransient_mark_mode)
417 && NILP (Vmark_even_if_inactive)
418 && NILP (BVAR (current_buffer, mark_active)))
419 xsignal0 (Qmark_inactive);
421 m = Fmarker_position (BVAR (current_buffer, mark));
422 if (NILP (m))
423 error ("The mark is not set now, so there is no region");
425 /* Clip to the current narrowing (bug#11770). */
426 return make_number ((PT < XFASTINT (m)) == beginningp
427 ? PT
428 : clip_to_bounds (BEGV, XFASTINT (m), ZV));
431 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
432 doc: /* Return the integer value of point or mark, whichever is smaller. */)
433 (void)
435 return region_limit (1);
438 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
439 doc: /* Return the integer value of point or mark, whichever is larger. */)
440 (void)
442 return region_limit (0);
445 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
446 doc: /* Return this buffer's mark, as a marker object.
447 Watch out! Moving this marker changes the mark position.
448 If you set the marker not to point anywhere, the buffer will have no mark. */)
449 (void)
451 return BVAR (current_buffer, mark);
455 /* Find all the overlays in the current buffer that touch position POS.
456 Return the number found, and store them in a vector in VEC
457 of length LEN. */
459 static ptrdiff_t
460 overlays_around (EMACS_INT pos, Lisp_Object *vec, ptrdiff_t len)
462 Lisp_Object overlay, start, end;
463 struct Lisp_Overlay *tail;
464 ptrdiff_t startpos, endpos;
465 ptrdiff_t idx = 0;
467 for (tail = current_buffer->overlays_before; tail; tail = tail->next)
469 XSETMISC (overlay, tail);
471 end = OVERLAY_END (overlay);
472 endpos = OVERLAY_POSITION (end);
473 if (endpos < pos)
474 break;
475 start = OVERLAY_START (overlay);
476 startpos = OVERLAY_POSITION (start);
477 if (startpos <= pos)
479 if (idx < len)
480 vec[idx] = overlay;
481 /* Keep counting overlays even if we can't return them all. */
482 idx++;
486 for (tail = current_buffer->overlays_after; tail; tail = tail->next)
488 XSETMISC (overlay, tail);
490 start = OVERLAY_START (overlay);
491 startpos = OVERLAY_POSITION (start);
492 if (pos < startpos)
493 break;
494 end = OVERLAY_END (overlay);
495 endpos = OVERLAY_POSITION (end);
496 if (pos <= endpos)
498 if (idx < len)
499 vec[idx] = overlay;
500 idx++;
504 return idx;
507 DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
508 doc: /* Return the value of POSITION's property PROP, in OBJECT.
509 Almost identical to `get-char-property' except for the following difference:
510 Whereas `get-char-property' returns the property of the char at (i.e. right
511 after) POSITION, this pays attention to properties's stickiness and overlays's
512 advancement settings, in order to find the property of POSITION itself,
513 i.e. the property that a char would inherit if it were inserted
514 at POSITION. */)
515 (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
517 CHECK_NUMBER_COERCE_MARKER (position);
519 if (NILP (object))
520 XSETBUFFER (object, current_buffer);
521 else if (WINDOWP (object))
522 object = XWINDOW (object)->contents;
524 if (!BUFFERP (object))
525 /* pos-property only makes sense in buffers right now, since strings
526 have no overlays and no notion of insertion for which stickiness
527 could be obeyed. */
528 return Fget_text_property (position, prop, object);
529 else
531 EMACS_INT posn = XINT (position);
532 ptrdiff_t noverlays;
533 Lisp_Object *overlay_vec, tem;
534 struct buffer *obuf = current_buffer;
535 USE_SAFE_ALLOCA;
537 set_buffer_temp (XBUFFER (object));
539 /* First try with room for 40 overlays. */
540 Lisp_Object overlay_vecbuf[40];
541 noverlays = ARRAYELTS (overlay_vecbuf);
542 overlay_vec = overlay_vecbuf;
543 noverlays = overlays_around (posn, overlay_vec, noverlays);
545 /* If there are more than 40,
546 make enough space for all, and try again. */
547 if (ARRAYELTS (overlay_vecbuf) < noverlays)
549 SAFE_ALLOCA_LISP (overlay_vec, noverlays);
550 noverlays = overlays_around (posn, overlay_vec, noverlays);
552 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
554 set_buffer_temp (obuf);
556 /* Now check the overlays in order of decreasing priority. */
557 while (--noverlays >= 0)
559 Lisp_Object ol = overlay_vec[noverlays];
560 tem = Foverlay_get (ol, prop);
561 if (!NILP (tem))
563 /* Check the overlay is indeed active at point. */
564 Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
565 if ((OVERLAY_POSITION (start) == posn
566 && XMARKER (start)->insertion_type == 1)
567 || (OVERLAY_POSITION (finish) == posn
568 && XMARKER (finish)->insertion_type == 0))
569 ; /* The overlay will not cover a char inserted at point. */
570 else
572 SAFE_FREE ();
573 return tem;
577 SAFE_FREE ();
579 { /* Now check the text properties. */
580 int stickiness = text_property_stickiness (prop, position, object);
581 if (stickiness > 0)
582 return Fget_text_property (position, prop, object);
583 else if (stickiness < 0
584 && XINT (position) > BUF_BEGV (XBUFFER (object)))
585 return Fget_text_property (make_number (XINT (position) - 1),
586 prop, object);
587 else
588 return Qnil;
593 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
594 the value of point is used instead. If BEG or END is null,
595 means don't store the beginning or end of the field.
597 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
598 results; they do not effect boundary behavior.
600 If MERGE_AT_BOUNDARY is non-nil, then if POS is at the very first
601 position of a field, then the beginning of the previous field is
602 returned instead of the beginning of POS's field (since the end of a
603 field is actually also the beginning of the next input field, this
604 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
605 non-nil case, if two fields are separated by a field with the special
606 value `boundary', and POS lies within it, then the two separated
607 fields are considered to be adjacent, and POS between them, when
608 finding the beginning and ending of the "merged" field.
610 Either BEG or END may be 0, in which case the corresponding value
611 is not stored. */
613 static void
614 find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
615 Lisp_Object beg_limit,
616 ptrdiff_t *beg, Lisp_Object end_limit, ptrdiff_t *end)
618 /* Fields right before and after the point. */
619 Lisp_Object before_field, after_field;
620 /* True if POS counts as the start of a field. */
621 bool at_field_start = 0;
622 /* True if POS counts as the end of a field. */
623 bool at_field_end = 0;
625 if (NILP (pos))
626 XSETFASTINT (pos, PT);
627 else
628 CHECK_NUMBER_COERCE_MARKER (pos);
630 after_field
631 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
632 before_field
633 = (XFASTINT (pos) > BEGV
634 ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
635 Qfield, Qnil, NULL)
636 /* Using nil here would be a more obvious choice, but it would
637 fail when the buffer starts with a non-sticky field. */
638 : after_field);
640 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
641 and POS is at beginning of a field, which can also be interpreted
642 as the end of the previous field. Note that the case where if
643 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
644 more natural one; then we avoid treating the beginning of a field
645 specially. */
646 if (NILP (merge_at_boundary))
648 Lisp_Object field = Fget_pos_property (pos, Qfield, Qnil);
649 if (!EQ (field, after_field))
650 at_field_end = 1;
651 if (!EQ (field, before_field))
652 at_field_start = 1;
653 if (NILP (field) && at_field_start && at_field_end)
654 /* If an inserted char would have a nil field while the surrounding
655 text is non-nil, we're probably not looking at a
656 zero-length field, but instead at a non-nil field that's
657 not intended for editing (such as comint's prompts). */
658 at_field_end = at_field_start = 0;
661 /* Note about special `boundary' fields:
663 Consider the case where the point (`.') is between the fields `x' and `y':
665 xxxx.yyyy
667 In this situation, if merge_at_boundary is non-nil, consider the
668 `x' and `y' fields as forming one big merged field, and so the end
669 of the field is the end of `y'.
671 However, if `x' and `y' are separated by a special `boundary' field
672 (a field with a `field' char-property of 'boundary), then ignore
673 this special field when merging adjacent fields. Here's the same
674 situation, but with a `boundary' field between the `x' and `y' fields:
676 xxx.BBBByyyy
678 Here, if point is at the end of `x', the beginning of `y', or
679 anywhere in-between (within the `boundary' field), merge all
680 three fields and consider the beginning as being the beginning of
681 the `x' field, and the end as being the end of the `y' field. */
683 if (beg)
685 if (at_field_start)
686 /* POS is at the edge of a field, and we should consider it as
687 the beginning of the following field. */
688 *beg = XFASTINT (pos);
689 else
690 /* Find the previous field boundary. */
692 Lisp_Object p = pos;
693 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
694 /* Skip a `boundary' field. */
695 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
696 beg_limit);
698 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
699 beg_limit);
700 *beg = NILP (p) ? BEGV : XFASTINT (p);
704 if (end)
706 if (at_field_end)
707 /* POS is at the edge of a field, and we should consider it as
708 the end of the previous field. */
709 *end = XFASTINT (pos);
710 else
711 /* Find the next field boundary. */
713 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
714 /* Skip a `boundary' field. */
715 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
716 end_limit);
718 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
719 end_limit);
720 *end = NILP (pos) ? ZV : XFASTINT (pos);
726 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
727 doc: /* Delete the field surrounding POS.
728 A field is a region of text with the same `field' property.
729 If POS is nil, the value of point is used for POS. */)
730 (Lisp_Object pos)
732 ptrdiff_t beg, end;
733 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
734 if (beg != end)
735 del_range (beg, end);
736 return Qnil;
739 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
740 doc: /* Return the contents of the field surrounding POS as a string.
741 A field is a region of text with the same `field' property.
742 If POS is nil, the value of point is used for POS. */)
743 (Lisp_Object pos)
745 ptrdiff_t beg, end;
746 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
747 return make_buffer_string (beg, end, 1);
750 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
751 doc: /* Return the contents of the field around POS, without text properties.
752 A field is a region of text with the same `field' property.
753 If POS is nil, the value of point is used for POS. */)
754 (Lisp_Object pos)
756 ptrdiff_t beg, end;
757 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
758 return make_buffer_string (beg, end, 0);
761 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
762 doc: /* Return the beginning of the field surrounding POS.
763 A field is a region of text with the same `field' property.
764 If POS is nil, the value of point is used for POS.
765 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
766 field, then the beginning of the *previous* field is returned.
767 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
768 is before LIMIT, then LIMIT will be returned instead. */)
769 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
771 ptrdiff_t beg;
772 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
773 return make_number (beg);
776 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
777 doc: /* Return the end of the field surrounding POS.
778 A field is a region of text with the same `field' property.
779 If POS is nil, the value of point is used for POS.
780 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
781 then the end of the *following* field is returned.
782 If LIMIT is non-nil, it is a buffer position; if the end of the field
783 is after LIMIT, then LIMIT will be returned instead. */)
784 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
786 ptrdiff_t end;
787 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
788 return make_number (end);
791 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
792 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
793 A field is a region of text with the same `field' property.
795 If NEW-POS is nil, then use the current point instead, and move point
796 to the resulting constrained position, in addition to returning that
797 position.
799 If OLD-POS is at the boundary of two fields, then the allowable
800 positions for NEW-POS depends on the value of the optional argument
801 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
802 constrained to the field that has the same `field' char-property
803 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
804 is non-nil, NEW-POS is constrained to the union of the two adjacent
805 fields. Additionally, if two fields are separated by another field with
806 the special value `boundary', then any point within this special field is
807 also considered to be `on the boundary'.
809 If the optional argument ONLY-IN-LINE is non-nil and constraining
810 NEW-POS would move it to a different line, NEW-POS is returned
811 unconstrained. This is useful for commands that move by line, like
812 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
813 only in the case where they can still move to the right line.
815 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
816 a non-nil property of that name, then any field boundaries are ignored.
818 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
819 (Lisp_Object new_pos, Lisp_Object old_pos, Lisp_Object escape_from_edge,
820 Lisp_Object only_in_line, Lisp_Object inhibit_capture_property)
822 /* If non-zero, then the original point, before re-positioning. */
823 ptrdiff_t orig_point = 0;
824 bool fwd;
825 Lisp_Object prev_old, prev_new;
827 if (NILP (new_pos))
828 /* Use the current point, and afterwards, set it. */
830 orig_point = PT;
831 XSETFASTINT (new_pos, PT);
834 CHECK_NUMBER_COERCE_MARKER (new_pos);
835 CHECK_NUMBER_COERCE_MARKER (old_pos);
837 fwd = (XINT (new_pos) > XINT (old_pos));
839 prev_old = make_number (XINT (old_pos) - 1);
840 prev_new = make_number (XINT (new_pos) - 1);
842 if (NILP (Vinhibit_field_text_motion)
843 && !EQ (new_pos, old_pos)
844 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
845 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
846 /* To recognize field boundaries, we must also look at the
847 previous positions; we could use `Fget_pos_property'
848 instead, but in itself that would fail inside non-sticky
849 fields (like comint prompts). */
850 || (XFASTINT (new_pos) > BEGV
851 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
852 || (XFASTINT (old_pos) > BEGV
853 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
854 && (NILP (inhibit_capture_property)
855 /* Field boundaries are again a problem; but now we must
856 decide the case exactly, so we need to call
857 `get_pos_property' as well. */
858 || (NILP (Fget_pos_property (old_pos, inhibit_capture_property, Qnil))
859 && (XFASTINT (old_pos) <= BEGV
860 || NILP (Fget_char_property
861 (old_pos, inhibit_capture_property, Qnil))
862 || NILP (Fget_char_property
863 (prev_old, inhibit_capture_property, Qnil))))))
864 /* It is possible that NEW_POS is not within the same field as
865 OLD_POS; try to move NEW_POS so that it is. */
867 ptrdiff_t shortage;
868 Lisp_Object field_bound;
870 if (fwd)
871 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
872 else
873 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
875 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
876 other side of NEW_POS, which would mean that NEW_POS is
877 already acceptable, and it's not necessary to constrain it
878 to FIELD_BOUND. */
879 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
880 /* NEW_POS should be constrained, but only if either
881 ONLY_IN_LINE is nil (in which case any constraint is OK),
882 or NEW_POS and FIELD_BOUND are on the same line (in which
883 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
884 && (NILP (only_in_line)
885 /* This is the ONLY_IN_LINE case, check that NEW_POS and
886 FIELD_BOUND are on the same line by seeing whether
887 there's an intervening newline or not. */
888 || (find_newline (XFASTINT (new_pos), -1,
889 XFASTINT (field_bound), -1,
890 fwd ? -1 : 1, &shortage, NULL, 1),
891 shortage != 0)))
892 /* Constrain NEW_POS to FIELD_BOUND. */
893 new_pos = field_bound;
895 if (orig_point && XFASTINT (new_pos) != orig_point)
896 /* The NEW_POS argument was originally nil, so automatically set PT. */
897 SET_PT (XFASTINT (new_pos));
900 return new_pos;
904 DEFUN ("line-beginning-position",
905 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
906 doc: /* Return the character position of the first character on the current line.
907 With optional argument N, scan forward N - 1 lines first.
908 If the scan reaches the end of the buffer, return that position.
910 This function ignores text display directionality; it returns the
911 position of the first character in logical order, i.e. the smallest
912 character position on the line.
914 This function constrains the returned position to the current field
915 unless that position would be on a different line than the original,
916 unconstrained result. If N is nil or 1, and a front-sticky field
917 starts at point, the scan stops as soon as it starts. To ignore field
918 boundaries, bind `inhibit-field-text-motion' to t.
920 This function does not move point. */)
921 (Lisp_Object n)
923 ptrdiff_t charpos, bytepos;
925 if (NILP (n))
926 XSETFASTINT (n, 1);
927 else
928 CHECK_NUMBER (n);
930 scan_newline_from_point (XINT (n) - 1, &charpos, &bytepos);
932 /* Return END constrained to the current input field. */
933 return Fconstrain_to_field (make_number (charpos), make_number (PT),
934 XINT (n) != 1 ? Qt : Qnil,
935 Qt, Qnil);
938 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
939 doc: /* Return the character position of the last character on the current line.
940 With argument N not nil or 1, move forward N - 1 lines first.
941 If scan reaches end of buffer, return that position.
943 This function ignores text display directionality; it returns the
944 position of the last character in logical order, i.e. the largest
945 character position on the line.
947 This function constrains the returned position to the current field
948 unless that would be on a different line than the original,
949 unconstrained result. If N is nil or 1, and a rear-sticky field ends
950 at point, the scan stops as soon as it starts. To ignore field
951 boundaries bind `inhibit-field-text-motion' to t.
953 This function does not move point. */)
954 (Lisp_Object n)
956 ptrdiff_t clipped_n;
957 ptrdiff_t end_pos;
958 ptrdiff_t orig = PT;
960 if (NILP (n))
961 XSETFASTINT (n, 1);
962 else
963 CHECK_NUMBER (n);
965 clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XINT (n), PTRDIFF_MAX);
966 end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0),
967 NULL);
969 /* Return END_POS constrained to the current input field. */
970 return Fconstrain_to_field (make_number (end_pos), make_number (orig),
971 Qnil, Qt, Qnil);
974 /* Save current buffer state for `save-excursion' special form.
975 We (ab)use Lisp_Misc_Save_Value to allow explicit free and so
976 offload some work from GC. */
978 Lisp_Object
979 save_excursion_save (void)
981 return make_save_obj_obj_obj_obj
982 (Fpoint_marker (),
983 Qnil,
984 /* Selected window if current buffer is shown in it, nil otherwise. */
985 (EQ (XWINDOW (selected_window)->contents, Fcurrent_buffer ())
986 ? selected_window : Qnil),
987 Qnil);
990 /* Restore saved buffer before leaving `save-excursion' special form. */
992 void
993 save_excursion_restore (Lisp_Object info)
995 Lisp_Object tem, tem1;
997 tem = Fmarker_buffer (XSAVE_OBJECT (info, 0));
998 /* If we're unwinding to top level, saved buffer may be deleted. This
999 means that all of its markers are unchained and so tem is nil. */
1000 if (NILP (tem))
1001 goto out;
1003 Fset_buffer (tem);
1005 /* Point marker. */
1006 tem = XSAVE_OBJECT (info, 0);
1007 Fgoto_char (tem);
1008 unchain_marker (XMARKER (tem));
1010 /* If buffer was visible in a window, and a different window was
1011 selected, and the old selected window is still showing this
1012 buffer, restore point in that window. */
1013 tem = XSAVE_OBJECT (info, 2);
1014 if (WINDOWP (tem)
1015 && !EQ (tem, selected_window)
1016 && (tem1 = XWINDOW (tem)->contents,
1017 (/* Window is live... */
1018 BUFFERP (tem1)
1019 /* ...and it shows the current buffer. */
1020 && XBUFFER (tem1) == current_buffer)))
1021 Fset_window_point (tem, make_number (PT));
1023 out:
1025 free_misc (info);
1028 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
1029 doc: /* Save point, and current buffer; execute BODY; restore those things.
1030 Executes BODY just like `progn'.
1031 The values of point and the current buffer are restored
1032 even in case of abnormal exit (throw or error).
1034 If you only want to save the current buffer but not point,
1035 then just use `save-current-buffer', or even `with-current-buffer'.
1037 Before Emacs 25.1, `save-excursion' used to save the mark state.
1038 To save the marker state as well as the point and buffer, use
1039 `save-mark-and-excursion'.
1041 usage: (save-excursion &rest BODY) */)
1042 (Lisp_Object args)
1044 register Lisp_Object val;
1045 ptrdiff_t count = SPECPDL_INDEX ();
1047 record_unwind_protect (save_excursion_restore, save_excursion_save ());
1049 val = Fprogn (args);
1050 return unbind_to (count, val);
1053 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
1054 doc: /* Record which buffer is current; execute BODY; make that buffer current.
1055 BODY is executed just like `progn'.
1056 usage: (save-current-buffer &rest BODY) */)
1057 (Lisp_Object args)
1059 ptrdiff_t count = SPECPDL_INDEX ();
1061 record_unwind_current_buffer ();
1062 return unbind_to (count, Fprogn (args));
1065 DEFUN ("buffer-size", Fbuffer_size, Sbuffer_size, 0, 1, 0,
1066 doc: /* Return the number of characters in the current buffer.
1067 If BUFFER, return the number of characters in that buffer instead. */)
1068 (Lisp_Object buffer)
1070 if (NILP (buffer))
1071 return make_number (Z - BEG);
1072 else
1074 CHECK_BUFFER (buffer);
1075 return make_number (BUF_Z (XBUFFER (buffer))
1076 - BUF_BEG (XBUFFER (buffer)));
1080 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
1081 doc: /* Return the minimum permissible value of point in the current buffer.
1082 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1083 (void)
1085 Lisp_Object temp;
1086 XSETFASTINT (temp, BEGV);
1087 return temp;
1090 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
1091 doc: /* Return a marker to the minimum permissible value of point in this buffer.
1092 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1093 (void)
1095 return build_marker (current_buffer, BEGV, BEGV_BYTE);
1098 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
1099 doc: /* Return the maximum permissible value of point in the current buffer.
1100 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1101 is in effect, in which case it is less. */)
1102 (void)
1104 Lisp_Object temp;
1105 XSETFASTINT (temp, ZV);
1106 return temp;
1109 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
1110 doc: /* Return a marker to the maximum permissible value of point in this buffer.
1111 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1112 is in effect, in which case it is less. */)
1113 (void)
1115 return build_marker (current_buffer, ZV, ZV_BYTE);
1118 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
1119 doc: /* Return the position of the gap, in the current buffer.
1120 See also `gap-size'. */)
1121 (void)
1123 Lisp_Object temp;
1124 XSETFASTINT (temp, GPT);
1125 return temp;
1128 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
1129 doc: /* Return the size of the current buffer's gap.
1130 See also `gap-position'. */)
1131 (void)
1133 Lisp_Object temp;
1134 XSETFASTINT (temp, GAP_SIZE);
1135 return temp;
1138 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
1139 doc: /* Return the byte position for character position POSITION.
1140 If POSITION is out of range, the value is nil. */)
1141 (Lisp_Object position)
1143 CHECK_NUMBER_COERCE_MARKER (position);
1144 if (XINT (position) < BEG || XINT (position) > Z)
1145 return Qnil;
1146 return make_number (CHAR_TO_BYTE (XINT (position)));
1149 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
1150 doc: /* Return the character position for byte position BYTEPOS.
1151 If BYTEPOS is out of range, the value is nil. */)
1152 (Lisp_Object bytepos)
1154 ptrdiff_t pos_byte;
1156 CHECK_NUMBER (bytepos);
1157 pos_byte = XINT (bytepos);
1158 if (pos_byte < BEG_BYTE || pos_byte > Z_BYTE)
1159 return Qnil;
1160 if (Z != Z_BYTE)
1161 /* There are multibyte characters in the buffer.
1162 The argument of BYTE_TO_CHAR must be a byte position at
1163 a character boundary, so search for the start of the current
1164 character. */
1165 while (!CHAR_HEAD_P (FETCH_BYTE (pos_byte)))
1166 pos_byte--;
1167 return make_number (BYTE_TO_CHAR (pos_byte));
1170 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
1171 doc: /* Return the character following point, as a number.
1172 At the end of the buffer or accessible region, return 0. */)
1173 (void)
1175 Lisp_Object temp;
1176 if (PT >= ZV)
1177 XSETFASTINT (temp, 0);
1178 else
1179 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
1180 return temp;
1183 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
1184 doc: /* Return the character preceding point, as a number.
1185 At the beginning of the buffer or accessible region, return 0. */)
1186 (void)
1188 Lisp_Object temp;
1189 if (PT <= BEGV)
1190 XSETFASTINT (temp, 0);
1191 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1193 ptrdiff_t pos = PT_BYTE;
1194 DEC_POS (pos);
1195 XSETFASTINT (temp, FETCH_CHAR (pos));
1197 else
1198 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
1199 return temp;
1202 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
1203 doc: /* Return t if point is at the beginning of the buffer.
1204 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1205 (void)
1207 if (PT == BEGV)
1208 return Qt;
1209 return Qnil;
1212 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
1213 doc: /* Return t if point is at the end of the buffer.
1214 If the buffer is narrowed, this means the end of the narrowed part. */)
1215 (void)
1217 if (PT == ZV)
1218 return Qt;
1219 return Qnil;
1222 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
1223 doc: /* Return t if point is at the beginning of a line. */)
1224 (void)
1226 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
1227 return Qt;
1228 return Qnil;
1231 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
1232 doc: /* Return t if point is at the end of a line.
1233 `End of a line' includes point being at the end of the buffer. */)
1234 (void)
1236 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
1237 return Qt;
1238 return Qnil;
1241 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
1242 doc: /* Return character in current buffer at position POS.
1243 POS is an integer or a marker and defaults to point.
1244 If POS is out of range, the value is nil. */)
1245 (Lisp_Object pos)
1247 register ptrdiff_t pos_byte;
1249 if (NILP (pos))
1251 pos_byte = PT_BYTE;
1252 XSETFASTINT (pos, PT);
1255 if (MARKERP (pos))
1257 pos_byte = marker_byte_position (pos);
1258 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1259 return Qnil;
1261 else
1263 CHECK_NUMBER_COERCE_MARKER (pos);
1264 if (XINT (pos) < BEGV || XINT (pos) >= ZV)
1265 return Qnil;
1267 pos_byte = CHAR_TO_BYTE (XINT (pos));
1270 return make_number (FETCH_CHAR (pos_byte));
1273 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
1274 doc: /* Return character in current buffer preceding position POS.
1275 POS is an integer or a marker and defaults to point.
1276 If POS is out of range, the value is nil. */)
1277 (Lisp_Object pos)
1279 register Lisp_Object val;
1280 register ptrdiff_t pos_byte;
1282 if (NILP (pos))
1284 pos_byte = PT_BYTE;
1285 XSETFASTINT (pos, PT);
1288 if (MARKERP (pos))
1290 pos_byte = marker_byte_position (pos);
1292 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
1293 return Qnil;
1295 else
1297 CHECK_NUMBER_COERCE_MARKER (pos);
1299 if (XINT (pos) <= BEGV || XINT (pos) > ZV)
1300 return Qnil;
1302 pos_byte = CHAR_TO_BYTE (XINT (pos));
1305 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1307 DEC_POS (pos_byte);
1308 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1310 else
1312 pos_byte--;
1313 XSETFASTINT (val, FETCH_BYTE (pos_byte));
1315 return val;
1318 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
1319 doc: /* Return the name under which the user logged in, as a string.
1320 This is based on the effective uid, not the real uid.
1321 Also, if the environment variables LOGNAME or USER are set,
1322 that determines the value of this function.
1324 If optional argument UID is an integer or a float, return the login name
1325 of the user with that uid, or nil if there is no such user. */)
1326 (Lisp_Object uid)
1328 struct passwd *pw;
1329 uid_t id;
1331 /* Set up the user name info if we didn't do it before.
1332 (That can happen if Emacs is dumpable
1333 but you decide to run `temacs -l loadup' and not dump. */
1334 if (NILP (Vuser_login_name))
1335 init_editfns (false);
1337 if (NILP (uid))
1338 return Vuser_login_name;
1340 CONS_TO_INTEGER (uid, uid_t, id);
1341 block_input ();
1342 pw = getpwuid (id);
1343 unblock_input ();
1344 return (pw ? build_string (pw->pw_name) : Qnil);
1347 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
1348 0, 0, 0,
1349 doc: /* Return the name of the user's real uid, as a string.
1350 This ignores the environment variables LOGNAME and USER, so it differs from
1351 `user-login-name' when running under `su'. */)
1352 (void)
1354 /* Set up the user name info if we didn't do it before.
1355 (That can happen if Emacs is dumpable
1356 but you decide to run `temacs -l loadup' and not dump. */
1357 if (NILP (Vuser_login_name))
1358 init_editfns (false);
1359 return Vuser_real_login_name;
1362 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1363 doc: /* Return the effective uid of Emacs.
1364 Value is an integer or a float, depending on the value. */)
1365 (void)
1367 uid_t euid = geteuid ();
1368 return make_fixnum_or_float (euid);
1371 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1372 doc: /* Return the real uid of Emacs.
1373 Value is an integer or a float, depending on the value. */)
1374 (void)
1376 uid_t uid = getuid ();
1377 return make_fixnum_or_float (uid);
1380 DEFUN ("group-gid", Fgroup_gid, Sgroup_gid, 0, 0, 0,
1381 doc: /* Return the effective gid of Emacs.
1382 Value is an integer or a float, depending on the value. */)
1383 (void)
1385 gid_t egid = getegid ();
1386 return make_fixnum_or_float (egid);
1389 DEFUN ("group-real-gid", Fgroup_real_gid, Sgroup_real_gid, 0, 0, 0,
1390 doc: /* Return the real gid of Emacs.
1391 Value is an integer or a float, depending on the value. */)
1392 (void)
1394 gid_t gid = getgid ();
1395 return make_fixnum_or_float (gid);
1398 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1399 doc: /* Return the full name of the user logged in, as a string.
1400 If the full name corresponding to Emacs's userid is not known,
1401 return "unknown".
1403 If optional argument UID is an integer or float, return the full name
1404 of the user with that uid, or nil if there is no such user.
1405 If UID is a string, return the full name of the user with that login
1406 name, or nil if there is no such user. */)
1407 (Lisp_Object uid)
1409 struct passwd *pw;
1410 register char *p, *q;
1411 Lisp_Object full;
1413 if (NILP (uid))
1414 return Vuser_full_name;
1415 else if (NUMBERP (uid))
1417 uid_t u;
1418 CONS_TO_INTEGER (uid, uid_t, u);
1419 block_input ();
1420 pw = getpwuid (u);
1421 unblock_input ();
1423 else if (STRINGP (uid))
1425 block_input ();
1426 pw = getpwnam (SSDATA (uid));
1427 unblock_input ();
1429 else
1430 error ("Invalid UID specification");
1432 if (!pw)
1433 return Qnil;
1435 p = USER_FULL_NAME;
1436 /* Chop off everything after the first comma. */
1437 q = strchr (p, ',');
1438 full = make_string (p, q ? q - p : strlen (p));
1440 #ifdef AMPERSAND_FULL_NAME
1441 p = SSDATA (full);
1442 q = strchr (p, '&');
1443 /* Substitute the login name for the &, upcasing the first character. */
1444 if (q)
1446 Lisp_Object login = Fuser_login_name (make_number (pw->pw_uid));
1447 USE_SAFE_ALLOCA;
1448 char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1);
1449 memcpy (r, p, q - p);
1450 char *s = lispstpcpy (&r[q - p], login);
1451 r[q - p] = upcase ((unsigned char) r[q - p]);
1452 strcpy (s, q + 1);
1453 full = build_string (r);
1454 SAFE_FREE ();
1456 #endif /* AMPERSAND_FULL_NAME */
1458 return full;
1461 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1462 doc: /* Return the host name of the machine you are running on, as a string. */)
1463 (void)
1465 if (EQ (Vsystem_name, cached_system_name))
1466 init_and_cache_system_name ();
1467 return Vsystem_name;
1470 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1471 doc: /* Return the process ID of Emacs, as a number. */)
1472 (void)
1474 pid_t pid = getpid ();
1475 return make_fixnum_or_float (pid);
1480 #ifndef TIME_T_MIN
1481 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1482 #endif
1483 #ifndef TIME_T_MAX
1484 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1485 #endif
1487 /* Report that a time value is out of range for Emacs. */
1488 void
1489 time_overflow (void)
1491 error ("Specified time is not representable");
1494 static _Noreturn void
1495 invalid_time (void)
1497 error ("Invalid time specification");
1500 /* Check a return value compatible with that of decode_time_components. */
1501 static void
1502 check_time_validity (int validity)
1504 if (validity <= 0)
1506 if (validity < 0)
1507 time_overflow ();
1508 else
1509 invalid_time ();
1513 /* Return the upper part of the time T (everything but the bottom 16 bits). */
1514 static EMACS_INT
1515 hi_time (time_t t)
1517 time_t hi = t >> LO_TIME_BITS;
1519 /* Check for overflow, helping the compiler for common cases where
1520 no runtime check is needed, and taking care not to convert
1521 negative numbers to unsigned before comparing them. */
1522 if (! ((! TYPE_SIGNED (time_t)
1523 || MOST_NEGATIVE_FIXNUM <= TIME_T_MIN >> LO_TIME_BITS
1524 || MOST_NEGATIVE_FIXNUM <= hi)
1525 && (TIME_T_MAX >> LO_TIME_BITS <= MOST_POSITIVE_FIXNUM
1526 || hi <= MOST_POSITIVE_FIXNUM)))
1527 time_overflow ();
1529 return hi;
1532 /* Return the bottom bits of the time T. */
1533 static int
1534 lo_time (time_t t)
1536 return t & ((1 << LO_TIME_BITS) - 1);
1539 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1540 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1541 The time is returned as a list of integers (HIGH LOW USEC PSEC).
1542 HIGH has the most significant bits of the seconds, while LOW has the
1543 least significant 16 bits. USEC and PSEC are the microsecond and
1544 picosecond counts. */)
1545 (void)
1547 return make_lisp_time (current_timespec ());
1550 static struct lisp_time
1551 time_add (struct lisp_time ta, struct lisp_time tb)
1553 EMACS_INT hi = ta.hi + tb.hi;
1554 int lo = ta.lo + tb.lo;
1555 int us = ta.us + tb.us;
1556 int ps = ta.ps + tb.ps;
1557 us += (1000000 <= ps);
1558 ps -= (1000000 <= ps) * 1000000;
1559 lo += (1000000 <= us);
1560 us -= (1000000 <= us) * 1000000;
1561 hi += (1 << LO_TIME_BITS <= lo);
1562 lo -= (1 << LO_TIME_BITS <= lo) << LO_TIME_BITS;
1563 return (struct lisp_time) { hi, lo, us, ps };
1566 static struct lisp_time
1567 time_subtract (struct lisp_time ta, struct lisp_time tb)
1569 EMACS_INT hi = ta.hi - tb.hi;
1570 int lo = ta.lo - tb.lo;
1571 int us = ta.us - tb.us;
1572 int ps = ta.ps - tb.ps;
1573 us -= (ps < 0);
1574 ps += (ps < 0) * 1000000;
1575 lo -= (us < 0);
1576 us += (us < 0) * 1000000;
1577 hi -= (lo < 0);
1578 lo += (lo < 0) << LO_TIME_BITS;
1579 return (struct lisp_time) { hi, lo, us, ps };
1582 static Lisp_Object
1583 time_arith (Lisp_Object a, Lisp_Object b,
1584 struct lisp_time (*op) (struct lisp_time, struct lisp_time))
1586 int alen, blen;
1587 struct lisp_time ta = lisp_time_struct (a, &alen);
1588 struct lisp_time tb = lisp_time_struct (b, &blen);
1589 struct lisp_time t = op (ta, tb);
1590 if (! (MOST_NEGATIVE_FIXNUM <= t.hi && t.hi <= MOST_POSITIVE_FIXNUM))
1591 time_overflow ();
1592 Lisp_Object val = Qnil;
1594 switch (max (alen, blen))
1596 default:
1597 val = Fcons (make_number (t.ps), val);
1598 /* Fall through. */
1599 case 3:
1600 val = Fcons (make_number (t.us), val);
1601 /* Fall through. */
1602 case 2:
1603 val = Fcons (make_number (t.lo), val);
1604 val = Fcons (make_number (t.hi), val);
1605 break;
1608 return val;
1611 DEFUN ("time-add", Ftime_add, Stime_add, 2, 2, 0,
1612 doc: /* Return the sum of two time values A and B, as a time value. */)
1613 (Lisp_Object a, Lisp_Object b)
1615 return time_arith (a, b, time_add);
1618 DEFUN ("time-subtract", Ftime_subtract, Stime_subtract, 2, 2, 0,
1619 doc: /* Return the difference between two time values A and B, as a time value. */)
1620 (Lisp_Object a, Lisp_Object b)
1622 return time_arith (a, b, time_subtract);
1625 DEFUN ("time-less-p", Ftime_less_p, Stime_less_p, 2, 2, 0,
1626 doc: /* Return non-nil if time value T1 is earlier than time value T2. */)
1627 (Lisp_Object t1, Lisp_Object t2)
1629 int t1len, t2len;
1630 struct lisp_time a = lisp_time_struct (t1, &t1len);
1631 struct lisp_time b = lisp_time_struct (t2, &t2len);
1632 return ((a.hi != b.hi ? a.hi < b.hi
1633 : a.lo != b.lo ? a.lo < b.lo
1634 : a.us != b.us ? a.us < b.us
1635 : a.ps < b.ps)
1636 ? Qt : Qnil);
1640 DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
1641 0, 0, 0,
1642 doc: /* Return the current run time used by Emacs.
1643 The time is returned as a list (HIGH LOW USEC PSEC), using the same
1644 style as (current-time).
1646 On systems that can't determine the run time, `get-internal-run-time'
1647 does the same thing as `current-time'. */)
1648 (void)
1650 #ifdef HAVE_GETRUSAGE
1651 struct rusage usage;
1652 time_t secs;
1653 int usecs;
1655 if (getrusage (RUSAGE_SELF, &usage) < 0)
1656 /* This shouldn't happen. What action is appropriate? */
1657 xsignal0 (Qerror);
1659 /* Sum up user time and system time. */
1660 secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
1661 usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
1662 if (usecs >= 1000000)
1664 usecs -= 1000000;
1665 secs++;
1667 return make_lisp_time (make_timespec (secs, usecs * 1000));
1668 #else /* ! HAVE_GETRUSAGE */
1669 #ifdef WINDOWSNT
1670 return w32_get_internal_run_time ();
1671 #else /* ! WINDOWSNT */
1672 return Fcurrent_time ();
1673 #endif /* WINDOWSNT */
1674 #endif /* HAVE_GETRUSAGE */
1678 /* Make a Lisp list that represents the Emacs time T. T may be an
1679 invalid time, with a slightly negative tv_nsec value such as
1680 UNKNOWN_MODTIME_NSECS; in that case, the Lisp list contains a
1681 correspondingly negative picosecond count. */
1682 Lisp_Object
1683 make_lisp_time (struct timespec t)
1685 time_t s = t.tv_sec;
1686 int ns = t.tv_nsec;
1687 return list4i (hi_time (s), lo_time (s), ns / 1000, ns % 1000 * 1000);
1690 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1691 Set *PHIGH, *PLOW, *PUSEC, *PPSEC to its parts; do not check their values.
1692 Return 2, 3, or 4 to indicate the effective length of SPECIFIED_TIME
1693 if successful, 0 if unsuccessful. */
1694 static int
1695 disassemble_lisp_time (Lisp_Object specified_time, Lisp_Object *phigh,
1696 Lisp_Object *plow, Lisp_Object *pusec,
1697 Lisp_Object *ppsec)
1699 Lisp_Object high = make_number (0);
1700 Lisp_Object low = specified_time;
1701 Lisp_Object usec = make_number (0);
1702 Lisp_Object psec = make_number (0);
1703 int len = 4;
1705 if (CONSP (specified_time))
1707 high = XCAR (specified_time);
1708 low = XCDR (specified_time);
1709 if (CONSP (low))
1711 Lisp_Object low_tail = XCDR (low);
1712 low = XCAR (low);
1713 if (CONSP (low_tail))
1715 usec = XCAR (low_tail);
1716 low_tail = XCDR (low_tail);
1717 if (CONSP (low_tail))
1718 psec = XCAR (low_tail);
1719 else
1720 len = 3;
1722 else if (!NILP (low_tail))
1724 usec = low_tail;
1725 len = 3;
1727 else
1728 len = 2;
1730 else
1731 len = 2;
1733 /* When combining components, require LOW to be an integer,
1734 as otherwise it would be a pain to add up times. */
1735 if (! INTEGERP (low))
1736 return 0;
1738 else if (INTEGERP (specified_time))
1739 len = 2;
1741 *phigh = high;
1742 *plow = low;
1743 *pusec = usec;
1744 *ppsec = psec;
1745 return len;
1748 /* Convert T into an Emacs time *RESULT, truncating toward minus infinity.
1749 Return true if T is in range, false otherwise. */
1750 static bool
1751 decode_float_time (double t, struct lisp_time *result)
1753 double lo_multiplier = 1 << LO_TIME_BITS;
1754 double emacs_time_min = MOST_NEGATIVE_FIXNUM * lo_multiplier;
1755 if (! (emacs_time_min <= t && t < -emacs_time_min))
1756 return false;
1758 double small_t = t / lo_multiplier;
1759 EMACS_INT hi = small_t;
1760 double t_sans_hi = t - hi * lo_multiplier;
1761 int lo = t_sans_hi;
1762 long double fracps = (t_sans_hi - lo) * 1e12L;
1763 #ifdef INT_FAST64_MAX
1764 int_fast64_t ifracps = fracps;
1765 int us = ifracps / 1000000;
1766 int ps = ifracps % 1000000;
1767 #else
1768 int us = fracps / 1e6L;
1769 int ps = fracps - us * 1e6L;
1770 #endif
1771 us -= (ps < 0);
1772 ps += (ps < 0) * 1000000;
1773 lo -= (us < 0);
1774 us += (us < 0) * 1000000;
1775 hi -= (lo < 0);
1776 lo += (lo < 0) << LO_TIME_BITS;
1777 result->hi = hi;
1778 result->lo = lo;
1779 result->us = us;
1780 result->ps = ps;
1781 return true;
1784 /* From the time components HIGH, LOW, USEC and PSEC taken from a Lisp
1785 list, generate the corresponding time value.
1786 If LOW is floating point, the other components should be zero.
1788 If RESULT is not null, store into *RESULT the converted time.
1789 If *DRESULT is not null, store into *DRESULT the number of
1790 seconds since the start of the POSIX Epoch.
1792 Return 1 if successful, 0 if the components are of the
1793 wrong type, and -1 if the time is out of range. */
1795 decode_time_components (Lisp_Object high, Lisp_Object low, Lisp_Object usec,
1796 Lisp_Object psec,
1797 struct lisp_time *result, double *dresult)
1799 EMACS_INT hi, lo, us, ps;
1800 if (! (INTEGERP (high)
1801 && INTEGERP (usec) && INTEGERP (psec)))
1802 return 0;
1803 if (! INTEGERP (low))
1805 if (FLOATP (low))
1807 double t = XFLOAT_DATA (low);
1808 if (result && ! decode_float_time (t, result))
1809 return -1;
1810 if (dresult)
1811 *dresult = t;
1812 return 1;
1814 else if (NILP (low))
1816 struct timespec now = current_timespec ();
1817 if (result)
1819 result->hi = hi_time (now.tv_sec);
1820 result->lo = lo_time (now.tv_sec);
1821 result->us = now.tv_nsec / 1000;
1822 result->ps = now.tv_nsec % 1000 * 1000;
1824 if (dresult)
1825 *dresult = now.tv_sec + now.tv_nsec / 1e9;
1826 return 1;
1828 else
1829 return 0;
1832 hi = XINT (high);
1833 lo = XINT (low);
1834 us = XINT (usec);
1835 ps = XINT (psec);
1837 /* Normalize out-of-range lower-order components by carrying
1838 each overflow into the next higher-order component. */
1839 us += ps / 1000000 - (ps % 1000000 < 0);
1840 lo += us / 1000000 - (us % 1000000 < 0);
1841 hi += lo >> LO_TIME_BITS;
1842 ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0);
1843 us = us % 1000000 + 1000000 * (us % 1000000 < 0);
1844 lo &= (1 << LO_TIME_BITS) - 1;
1846 if (result)
1848 if (! (MOST_NEGATIVE_FIXNUM <= hi && hi <= MOST_POSITIVE_FIXNUM))
1849 return -1;
1850 result->hi = hi;
1851 result->lo = lo;
1852 result->us = us;
1853 result->ps = ps;
1856 if (dresult)
1858 double dhi = hi;
1859 *dresult = (us * 1e6 + ps) / 1e12 + lo + dhi * (1 << LO_TIME_BITS);
1862 return 1;
1865 struct timespec
1866 lisp_to_timespec (struct lisp_time t)
1868 if (! ((TYPE_SIGNED (time_t) ? TIME_T_MIN >> LO_TIME_BITS <= t.hi : 0 <= t.hi)
1869 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1870 return invalid_timespec ();
1871 time_t s = (t.hi << LO_TIME_BITS) + t.lo;
1872 int ns = t.us * 1000 + t.ps / 1000;
1873 return make_timespec (s, ns);
1876 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1877 Store its effective length into *PLEN.
1878 If SPECIFIED_TIME is nil, use the current time.
1879 Signal an error if SPECIFIED_TIME does not represent a time. */
1880 static struct lisp_time
1881 lisp_time_struct (Lisp_Object specified_time, int *plen)
1883 Lisp_Object high, low, usec, psec;
1884 struct lisp_time t;
1885 int len = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1886 if (!len)
1887 invalid_time ();
1888 int val = decode_time_components (high, low, usec, psec, &t, 0);
1889 check_time_validity (val);
1890 *plen = len;
1891 return t;
1894 /* Like lisp_time_struct, except return a struct timespec.
1895 Discard any low-order digits. */
1896 struct timespec
1897 lisp_time_argument (Lisp_Object specified_time)
1899 int len;
1900 struct lisp_time lt = lisp_time_struct (specified_time, &len);
1901 struct timespec t = lisp_to_timespec (lt);
1902 if (! timespec_valid_p (t))
1903 time_overflow ();
1904 return t;
1907 /* Like lisp_time_argument, except decode only the seconds part,
1908 and do not check the subseconds part. */
1909 static time_t
1910 lisp_seconds_argument (Lisp_Object specified_time)
1912 Lisp_Object high, low, usec, psec;
1913 struct lisp_time t;
1915 int val = disassemble_lisp_time (specified_time, &high, &low, &usec, &psec);
1916 if (val != 0)
1918 val = decode_time_components (high, low, make_number (0),
1919 make_number (0), &t, 0);
1920 if (0 < val
1921 && ! ((TYPE_SIGNED (time_t)
1922 ? TIME_T_MIN >> LO_TIME_BITS <= t.hi
1923 : 0 <= t.hi)
1924 && t.hi <= TIME_T_MAX >> LO_TIME_BITS))
1925 val = -1;
1927 check_time_validity (val);
1928 return (t.hi << LO_TIME_BITS) + t.lo;
1931 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1932 doc: /* Return the current time, as a float number of seconds since the epoch.
1933 If SPECIFIED-TIME is given, it is the time to convert to float
1934 instead of the current time. The argument should have the form
1935 \(HIGH LOW) or (HIGH LOW USEC) or (HIGH LOW USEC PSEC). Thus,
1936 you can use times from `current-time' and from `file-attributes'.
1937 SPECIFIED-TIME can also have the form (HIGH . LOW), but this is
1938 considered obsolete.
1940 WARNING: Since the result is floating point, it may not be exact.
1941 If precise time stamps are required, use either `current-time',
1942 or (if you need time as a string) `format-time-string'. */)
1943 (Lisp_Object specified_time)
1945 double t;
1946 Lisp_Object high, low, usec, psec;
1947 if (! (disassemble_lisp_time (specified_time, &high, &low, &usec, &psec)
1948 && decode_time_components (high, low, usec, psec, 0, &t)))
1949 invalid_time ();
1950 return make_float (t);
1953 /* Write information into buffer S of size MAXSIZE, according to the
1954 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1955 Use the time zone specified by TZ.
1956 Use NS as the number of nanoseconds in the %N directive.
1957 Return the number of bytes written, not including the terminating
1958 '\0'. If S is NULL, nothing will be written anywhere; so to
1959 determine how many bytes would be written, use NULL for S and
1960 ((size_t) -1) for MAXSIZE.
1962 This function behaves like nstrftime, except it allows null
1963 bytes in FORMAT and it does not support nanoseconds. */
1964 static size_t
1965 emacs_nmemftime (char *s, size_t maxsize, const char *format,
1966 size_t format_len, const struct tm *tp, timezone_t tz, int ns)
1968 size_t total = 0;
1970 /* Loop through all the null-terminated strings in the format
1971 argument. Normally there's just one null-terminated string, but
1972 there can be arbitrarily many, concatenated together, if the
1973 format contains '\0' bytes. nstrftime stops at the first
1974 '\0' byte so we must invoke it separately for each such string. */
1975 for (;;)
1977 size_t len;
1978 size_t result;
1980 if (s)
1981 s[0] = '\1';
1983 result = nstrftime (s, maxsize, format, tp, tz, ns);
1985 if (s)
1987 if (result == 0 && s[0] != '\0')
1988 return 0;
1989 s += result + 1;
1992 maxsize -= result + 1;
1993 total += result;
1994 len = strlen (format);
1995 if (len == format_len)
1996 return total;
1997 total++;
1998 format += len + 1;
1999 format_len -= len + 1;
2003 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
2004 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
2005 TIME is specified as (HIGH LOW USEC PSEC), as returned by
2006 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
2007 is also still accepted.
2009 The optional ZONE is omitted or nil for Emacs local time, t for
2010 Universal Time, `wall' for system wall clock time, or a string as in
2011 the TZ environment variable. It can also be a list (as from
2012 `current-time-zone') or an integer (as from `decode-time') applied
2013 without consideration for daylight saving time.
2015 The value is a copy of FORMAT-STRING, but with certain constructs replaced
2016 by text that describes the specified date and time in TIME:
2018 %Y is the year, %y within the century, %C the century.
2019 %G is the year corresponding to the ISO week, %g within the century.
2020 %m is the numeric month.
2021 %b and %h are the locale's abbreviated month name, %B the full name.
2022 (%h is not supported on MS-Windows.)
2023 %d is the day of the month, zero-padded, %e is blank-padded.
2024 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
2025 %a is the locale's abbreviated name of the day of week, %A the full name.
2026 %U is the week number starting on Sunday, %W starting on Monday,
2027 %V according to ISO 8601.
2028 %j is the day of the year.
2030 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
2031 only blank-padded, %l is like %I blank-padded.
2032 %p is the locale's equivalent of either AM or PM.
2033 %M is the minute.
2034 %S is the second.
2035 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
2036 %Z is the time zone name, %z is the numeric form.
2037 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
2039 %c is the locale's date and time format.
2040 %x is the locale's "preferred" date format.
2041 %D is like "%m/%d/%y".
2042 %F is the ISO 8601 date format (like "%Y-%m-%d").
2044 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
2045 %X is the locale's "preferred" time format.
2047 Finally, %n is a newline, %t is a tab, %% is a literal %.
2049 Certain flags and modifiers are available with some format controls.
2050 The flags are `_', `-', `^' and `#'. For certain characters X,
2051 %_X is like %X, but padded with blanks; %-X is like %X,
2052 but without padding. %^X is like %X, but with all textual
2053 characters up-cased; %#X is like %X, but with letter-case of
2054 all textual characters reversed.
2055 %NX (where N stands for an integer) is like %X,
2056 but takes up at least N (a number) positions.
2057 The modifiers are `E' and `O'. For certain characters X,
2058 %EX is a locale's alternative version of %X;
2059 %OX is like %X, but uses the locale's number symbols.
2061 For example, to produce full ISO 8601 format, use "%FT%T%z".
2063 usage: (format-time-string FORMAT-STRING &optional TIME ZONE) */)
2064 (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object zone)
2066 struct timespec t = lisp_time_argument (timeval);
2067 struct tm tm;
2069 CHECK_STRING (format_string);
2070 format_string = code_convert_string_norecord (format_string,
2071 Vlocale_coding_system, 1);
2072 return format_time_string (SSDATA (format_string), SBYTES (format_string),
2073 t, zone, &tm);
2076 static Lisp_Object
2077 format_time_string (char const *format, ptrdiff_t formatlen,
2078 struct timespec t, Lisp_Object zone, struct tm *tmp)
2080 char buffer[4000];
2081 char *buf = buffer;
2082 ptrdiff_t size = sizeof buffer;
2083 size_t len;
2084 int ns = t.tv_nsec;
2085 USE_SAFE_ALLOCA;
2087 timezone_t tz = tzlookup (zone, false);
2088 tmp = emacs_localtime_rz (tz, &t.tv_sec, tmp);
2089 if (! tmp)
2091 xtzfree (tz);
2092 time_overflow ();
2094 synchronize_system_time_locale ();
2096 while (true)
2098 buf[0] = '\1';
2099 len = emacs_nmemftime (buf, size, format, formatlen, tmp, tz, ns);
2100 if ((0 < len && len < size) || (len == 0 && buf[0] == '\0'))
2101 break;
2103 /* Buffer was too small, so make it bigger and try again. */
2104 len = emacs_nmemftime (NULL, SIZE_MAX, format, formatlen, tmp, tz, ns);
2105 if (STRING_BYTES_BOUND <= len)
2107 xtzfree (tz);
2108 string_overflow ();
2110 size = len + 1;
2111 buf = SAFE_ALLOCA (size);
2114 xtzfree (tz);
2115 AUTO_STRING_WITH_LEN (bufstring, buf, len);
2116 Lisp_Object result = code_convert_string_norecord (bufstring,
2117 Vlocale_coding_system, 0);
2118 SAFE_FREE ();
2119 return result;
2122 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 2, 0,
2123 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST UTCOFF).
2124 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
2125 as from `current-time' and `file-attributes', or nil to use the
2126 current time. The obsolete form (HIGH . LOW) is also still accepted.
2128 The optional ZONE is omitted or nil for Emacs local time, t for
2129 Universal Time, `wall' for system wall clock time, or a string as in
2130 the TZ environment variable. It can also be a list (as from
2131 `current-time-zone') or an integer (as from `decode-time') applied
2132 without consideration for daylight saving time.
2134 The list has the following nine members: SEC is an integer between 0
2135 and 60; SEC is 60 for a leap second, which only some operating systems
2136 support. MINUTE is an integer between 0 and 59. HOUR is an integer
2137 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
2138 integer between 1 and 12. YEAR is an integer indicating the
2139 four-digit year. DOW is the day of week, an integer between 0 and 6,
2140 where 0 is Sunday. DST is t if daylight saving time is in effect,
2141 otherwise nil. UTCOFF is an integer indicating the UTC offset in
2142 seconds, i.e., the number of seconds east of Greenwich. (Note that
2143 Common Lisp has different meanings for DOW and UTCOFF.)
2145 usage: (decode-time &optional TIME ZONE) */)
2146 (Lisp_Object specified_time, Lisp_Object zone)
2148 time_t time_spec = lisp_seconds_argument (specified_time);
2149 struct tm local_tm, gmt_tm;
2150 timezone_t tz = tzlookup (zone, false);
2151 struct tm *tm = emacs_localtime_rz (tz, &time_spec, &local_tm);
2152 xtzfree (tz);
2154 if (! (tm
2155 && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= local_tm.tm_year
2156 && local_tm.tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE))
2157 time_overflow ();
2159 /* Avoid overflow when INT_MAX < EMACS_INT_MAX. */
2160 EMACS_INT tm_year_base = TM_YEAR_BASE;
2162 return CALLN (Flist,
2163 make_number (local_tm.tm_sec),
2164 make_number (local_tm.tm_min),
2165 make_number (local_tm.tm_hour),
2166 make_number (local_tm.tm_mday),
2167 make_number (local_tm.tm_mon + 1),
2168 make_number (local_tm.tm_year + tm_year_base),
2169 make_number (local_tm.tm_wday),
2170 local_tm.tm_isdst ? Qt : Qnil,
2171 (HAVE_TM_GMTOFF
2172 ? make_number (tm_gmtoff (&local_tm))
2173 : gmtime_r (&time_spec, &gmt_tm)
2174 ? make_number (tm_diff (&local_tm, &gmt_tm))
2175 : Qnil));
2178 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
2179 the result is representable as an int. Assume OFFSET is small and
2180 nonnegative. */
2181 static int
2182 check_tm_member (Lisp_Object obj, int offset)
2184 EMACS_INT n;
2185 CHECK_NUMBER (obj);
2186 n = XINT (obj);
2187 if (! (INT_MIN + offset <= n && n - offset <= INT_MAX))
2188 time_overflow ();
2189 return n - offset;
2192 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
2193 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
2194 This is the reverse operation of `decode-time', which see.
2196 The optional ZONE is omitted or nil for Emacs local time, t for
2197 Universal Time, `wall' for system wall clock time, or a string as in
2198 the TZ environment variable. It can also be a list (as from
2199 `current-time-zone') or an integer (as from `decode-time') applied
2200 without consideration for daylight saving time.
2202 You can pass more than 7 arguments; then the first six arguments
2203 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
2204 The intervening arguments are ignored.
2205 This feature lets (apply \\='encode-time (decode-time ...)) work.
2207 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
2208 for example, a DAY of 0 means the day preceding the given month.
2209 Year numbers less than 100 are treated just like other year numbers.
2210 If you want them to stand for years in this century, you must do that yourself.
2212 Years before 1970 are not guaranteed to work. On some systems,
2213 year values as low as 1901 do work.
2215 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
2216 (ptrdiff_t nargs, Lisp_Object *args)
2218 time_t value;
2219 struct tm tm;
2220 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
2222 tm.tm_sec = check_tm_member (args[0], 0);
2223 tm.tm_min = check_tm_member (args[1], 0);
2224 tm.tm_hour = check_tm_member (args[2], 0);
2225 tm.tm_mday = check_tm_member (args[3], 0);
2226 tm.tm_mon = check_tm_member (args[4], 1);
2227 tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
2228 tm.tm_isdst = -1;
2230 timezone_t tz = tzlookup (zone, false);
2231 value = emacs_mktime_z (tz, &tm);
2232 xtzfree (tz);
2234 if (value == (time_t) -1)
2235 time_overflow ();
2237 return list2i (hi_time (value), lo_time (value));
2240 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
2241 0, 2, 0,
2242 doc: /* Return the current local time, as a human-readable string.
2243 Programs can use this function to decode a time,
2244 since the number of columns in each field is fixed
2245 if the year is in the range 1000-9999.
2246 The format is `Sun Sep 16 01:03:52 1973'.
2247 However, see also the functions `decode-time' and `format-time-string'
2248 which provide a much more powerful and general facility.
2250 If SPECIFIED-TIME is given, it is a time to format instead of the
2251 current time. The argument should have the form (HIGH LOW . IGNORED).
2252 Thus, you can use times obtained from `current-time' and from
2253 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
2254 but this is considered obsolete.
2256 The optional ZONE is omitted or nil for Emacs local time, t for
2257 Universal Time, `wall' for system wall clock time, or a string as in
2258 the TZ environment variable. It can also be a list (as from
2259 `current-time-zone') or an integer (as from `decode-time') applied
2260 without consideration for daylight saving time. */)
2261 (Lisp_Object specified_time, Lisp_Object zone)
2263 time_t value = lisp_seconds_argument (specified_time);
2264 timezone_t tz = tzlookup (zone, false);
2266 /* Convert to a string in ctime format, except without the trailing
2267 newline, and without the 4-digit year limit. Don't use asctime
2268 or ctime, as they might dump core if the year is outside the
2269 range -999 .. 9999. */
2270 struct tm tm;
2271 struct tm *tmp = emacs_localtime_rz (tz, &value, &tm);
2272 xtzfree (tz);
2273 if (! tmp)
2274 time_overflow ();
2276 static char const wday_name[][4] =
2277 { "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" };
2278 static char const mon_name[][4] =
2279 { "Jan", "Feb", "Mar", "Apr", "May", "Jun",
2280 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" };
2281 printmax_t year_base = TM_YEAR_BASE;
2282 char buf[sizeof "Mon Apr 30 12:49:17 " + INT_STRLEN_BOUND (int) + 1];
2283 int len = sprintf (buf, "%s %s%3d %02d:%02d:%02d %"pMd,
2284 wday_name[tm.tm_wday], mon_name[tm.tm_mon], tm.tm_mday,
2285 tm.tm_hour, tm.tm_min, tm.tm_sec,
2286 tm.tm_year + year_base);
2288 return make_unibyte_string (buf, len);
2291 /* Yield A - B, measured in seconds.
2292 This function is copied from the GNU C Library. */
2293 static int
2294 tm_diff (struct tm *a, struct tm *b)
2296 /* Compute intervening leap days correctly even if year is negative.
2297 Take care to avoid int overflow in leap day calculations,
2298 but it's OK to assume that A and B are close to each other. */
2299 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
2300 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
2301 int a100 = a4 / 25 - (a4 % 25 < 0);
2302 int b100 = b4 / 25 - (b4 % 25 < 0);
2303 int a400 = a100 >> 2;
2304 int b400 = b100 >> 2;
2305 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
2306 int years = a->tm_year - b->tm_year;
2307 int days = (365 * years + intervening_leap_days
2308 + (a->tm_yday - b->tm_yday));
2309 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
2310 + (a->tm_min - b->tm_min))
2311 + (a->tm_sec - b->tm_sec));
2314 /* Yield A's UTC offset, or an unspecified value if unknown. */
2315 static long int
2316 tm_gmtoff (struct tm *a)
2318 #if HAVE_TM_GMTOFF
2319 return a->tm_gmtoff;
2320 #else
2321 return 0;
2322 #endif
2325 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 2, 0,
2326 doc: /* Return the offset and name for the local time zone.
2327 This returns a list of the form (OFFSET NAME).
2328 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
2329 A negative value means west of Greenwich.
2330 NAME is a string giving the name of the time zone.
2331 If SPECIFIED-TIME is given, the time zone offset is determined from it
2332 instead of using the current time. The argument should have the form
2333 \(HIGH LOW . IGNORED). Thus, you can use times obtained from
2334 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
2335 have the form (HIGH . LOW), but this is considered obsolete.
2337 The optional ZONE is omitted or nil for Emacs local time, t for
2338 Universal Time, `wall' for system wall clock time, or a string as in
2339 the TZ environment variable. It can also be a list (as from
2340 `current-time-zone') or an integer (as from `decode-time') applied
2341 without consideration for daylight saving time.
2343 Some operating systems cannot provide all this information to Emacs;
2344 in this case, `current-time-zone' returns a list containing nil for
2345 the data it can't find. */)
2346 (Lisp_Object specified_time, Lisp_Object zone)
2348 struct timespec value;
2349 struct tm local_tm, gmt_tm;
2350 Lisp_Object zone_offset, zone_name;
2352 zone_offset = Qnil;
2353 value = make_timespec (lisp_seconds_argument (specified_time), 0);
2354 zone_name = format_time_string ("%Z", sizeof "%Z" - 1, value,
2355 zone, &local_tm);
2357 if (HAVE_TM_GMTOFF || gmtime_r (&value.tv_sec, &gmt_tm))
2359 long int offset = (HAVE_TM_GMTOFF
2360 ? tm_gmtoff (&local_tm)
2361 : tm_diff (&local_tm, &gmt_tm));
2362 zone_offset = make_number (offset);
2363 if (SCHARS (zone_name) == 0)
2365 /* No local time zone name is available; use numeric zone instead. */
2366 long int hour = offset / 3600;
2367 int min_sec = offset % 3600;
2368 int amin_sec = min_sec < 0 ? - min_sec : min_sec;
2369 int min = amin_sec / 60;
2370 int sec = amin_sec % 60;
2371 int min_prec = min_sec ? 2 : 0;
2372 int sec_prec = sec ? 2 : 0;
2373 char buf[sizeof "+0000" + INT_STRLEN_BOUND (long int)];
2374 zone_name = make_formatted_string (buf, "%c%.2ld%.*d%.*d",
2375 (offset < 0 ? '-' : '+'),
2376 hour, min_prec, min, sec_prec, sec);
2380 return list2 (zone_offset, zone_name);
2383 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
2384 doc: /* Set the Emacs local time zone using TZ, a string specifying a time zone rule.
2385 If TZ is nil or `wall', use system wall clock time; this differs from
2386 the usual Emacs convention where nil means current local time. If TZ
2387 is t, use Universal Time. If TZ is a list (as from
2388 `current-time-zone') or an integer (as from `decode-time'), use the
2389 specified time zone without consideration for daylight saving time.
2391 Instead of calling this function, you typically want something else.
2392 To temporarily use a different time zone rule for just one invocation
2393 of `decode-time', `encode-time', or `format-time-string', pass the
2394 function a ZONE argument. To change local time consistently
2395 throughout Emacs, call (setenv "TZ" TZ): this changes both the
2396 environment of the Emacs process and the variable
2397 `process-environment', whereas `set-time-zone-rule' affects only the
2398 former. */)
2399 (Lisp_Object tz)
2401 tzlookup (NILP (tz) ? Qwall : tz, true);
2402 return Qnil;
2405 /* A buffer holding a string of the form "TZ=value", intended
2406 to be part of the environment. If TZ is supposed to be unset,
2407 the buffer string is "tZ=". */
2408 static char *tzvalbuf;
2410 /* Get the local time zone rule. */
2411 char *
2412 emacs_getenv_TZ (void)
2414 return tzvalbuf[0] == 'T' ? tzvalbuf + tzeqlen : 0;
2417 /* Set the local time zone rule to TZSTRING, which can be null to
2418 denote wall clock time. Do not record the setting in LOCAL_TZ.
2420 This function is not thread-safe, in theory because putenv is not,
2421 but mostly because of the static storage it updates. Other threads
2422 that invoke localtime etc. may be adversely affected while this
2423 function is executing. */
2426 emacs_setenv_TZ (const char *tzstring)
2428 static ptrdiff_t tzvalbufsize;
2429 ptrdiff_t tzstringlen = tzstring ? strlen (tzstring) : 0;
2430 char *tzval = tzvalbuf;
2431 bool new_tzvalbuf = tzvalbufsize <= tzeqlen + tzstringlen;
2433 if (new_tzvalbuf)
2435 /* Do not attempt to free the old tzvalbuf, since another thread
2436 may be using it. In practice, the first allocation is large
2437 enough and memory does not leak. */
2438 tzval = xpalloc (NULL, &tzvalbufsize,
2439 tzeqlen + tzstringlen - tzvalbufsize + 1, -1, 1);
2440 tzvalbuf = tzval;
2441 tzval[1] = 'Z';
2442 tzval[2] = '=';
2445 if (tzstring)
2447 /* Modify TZVAL in place. Although this is dicey in a
2448 multithreaded environment, we know of no portable alternative.
2449 Calling putenv or setenv could crash some other thread. */
2450 tzval[0] = 'T';
2451 strcpy (tzval + tzeqlen, tzstring);
2453 else
2455 /* Turn 'TZ=whatever' into an empty environment variable 'tZ='.
2456 Although this is also dicey, calling unsetenv here can crash Emacs.
2457 See Bug#8705. */
2458 tzval[0] = 't';
2459 tzval[tzeqlen] = 0;
2462 if (new_tzvalbuf
2463 #ifdef WINDOWSNT
2464 /* MS-Windows implementation of 'putenv' copies the argument
2465 string into a block it allocates, so modifying tzval string
2466 does not change the environment. OTOH, the other threads run
2467 by Emacs on MS-Windows never call 'xputenv' or 'putenv' or
2468 'unsetenv', so the original cause for the dicey in-place
2469 modification technique doesn't exist there in the first
2470 place. */
2471 || 1
2472 #endif
2475 /* Although this is not thread-safe, in practice this runs only
2476 on startup when there is only one thread. */
2477 xputenv (tzval);
2480 return 0;
2483 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2484 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2485 type of object is Lisp_String). INHERIT is passed to
2486 INSERT_FROM_STRING_FUNC as the last argument. */
2488 static void
2489 general_insert_function (void (*insert_func)
2490 (const char *, ptrdiff_t),
2491 void (*insert_from_string_func)
2492 (Lisp_Object, ptrdiff_t, ptrdiff_t,
2493 ptrdiff_t, ptrdiff_t, bool),
2494 bool inherit, ptrdiff_t nargs, Lisp_Object *args)
2496 ptrdiff_t argnum;
2497 Lisp_Object val;
2499 for (argnum = 0; argnum < nargs; argnum++)
2501 val = args[argnum];
2502 if (CHARACTERP (val))
2504 int c = XFASTINT (val);
2505 unsigned char str[MAX_MULTIBYTE_LENGTH];
2506 int len;
2508 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2509 len = CHAR_STRING (c, str);
2510 else
2512 str[0] = CHAR_TO_BYTE8 (c);
2513 len = 1;
2515 (*insert_func) ((char *) str, len);
2517 else if (STRINGP (val))
2519 (*insert_from_string_func) (val, 0, 0,
2520 SCHARS (val),
2521 SBYTES (val),
2522 inherit);
2524 else
2525 wrong_type_argument (Qchar_or_string_p, val);
2529 void
2530 insert1 (Lisp_Object arg)
2532 Finsert (1, &arg);
2536 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
2537 doc: /* Insert the arguments, either strings or characters, at point.
2538 Point and after-insertion markers move forward to end up
2539 after the inserted text.
2540 Any other markers at the point of insertion remain before the text.
2542 If the current buffer is multibyte, unibyte strings are converted
2543 to multibyte for insertion (see `string-make-multibyte').
2544 If the current buffer is unibyte, multibyte strings are converted
2545 to unibyte for insertion (see `string-make-unibyte').
2547 When operating on binary data, it may be necessary to preserve the
2548 original bytes of a unibyte string when inserting it into a multibyte
2549 buffer; to accomplish this, apply `string-as-multibyte' to the string
2550 and insert the result.
2552 usage: (insert &rest ARGS) */)
2553 (ptrdiff_t nargs, Lisp_Object *args)
2555 general_insert_function (insert, insert_from_string, 0, nargs, args);
2556 return Qnil;
2559 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
2560 0, MANY, 0,
2561 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
2562 Point and after-insertion markers move forward to end up
2563 after the inserted text.
2564 Any other markers at the point of insertion remain before the text.
2566 If the current buffer is multibyte, unibyte strings are converted
2567 to multibyte for insertion (see `unibyte-char-to-multibyte').
2568 If the current buffer is unibyte, multibyte strings are converted
2569 to unibyte for insertion.
2571 usage: (insert-and-inherit &rest ARGS) */)
2572 (ptrdiff_t nargs, Lisp_Object *args)
2574 general_insert_function (insert_and_inherit, insert_from_string, 1,
2575 nargs, args);
2576 return Qnil;
2579 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
2580 doc: /* Insert strings or characters at point, relocating markers after the text.
2581 Point and markers move forward to end up after the inserted text.
2583 If the current buffer is multibyte, unibyte strings are converted
2584 to multibyte for insertion (see `unibyte-char-to-multibyte').
2585 If the current buffer is unibyte, multibyte strings are converted
2586 to unibyte for insertion.
2588 If an overlay begins at the insertion point, the inserted text falls
2589 outside the overlay; if a nonempty overlay ends at the insertion
2590 point, the inserted text falls inside that overlay.
2592 usage: (insert-before-markers &rest ARGS) */)
2593 (ptrdiff_t nargs, Lisp_Object *args)
2595 general_insert_function (insert_before_markers,
2596 insert_from_string_before_markers, 0,
2597 nargs, args);
2598 return Qnil;
2601 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
2602 Sinsert_and_inherit_before_markers, 0, MANY, 0,
2603 doc: /* Insert text at point, relocating markers and inheriting properties.
2604 Point and markers move forward to end up after the inserted text.
2606 If the current buffer is multibyte, unibyte strings are converted
2607 to multibyte for insertion (see `unibyte-char-to-multibyte').
2608 If the current buffer is unibyte, multibyte strings are converted
2609 to unibyte for insertion.
2611 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2612 (ptrdiff_t nargs, Lisp_Object *args)
2614 general_insert_function (insert_before_markers_and_inherit,
2615 insert_from_string_before_markers, 1,
2616 nargs, args);
2617 return Qnil;
2620 DEFUN ("insert-char", Finsert_char, Sinsert_char, 1, 3,
2621 "(list (read-char-by-name \"Insert character (Unicode name or hex): \")\
2622 (prefix-numeric-value current-prefix-arg)\
2623 t))",
2624 doc: /* Insert COUNT copies of CHARACTER.
2625 Interactively, prompt for CHARACTER. You can specify CHARACTER in one
2626 of these ways:
2628 - As its Unicode character name, e.g. \"LATIN SMALL LETTER A\".
2629 Completion is available; if you type a substring of the name
2630 preceded by an asterisk `*', Emacs shows all names which include
2631 that substring, not necessarily at the beginning of the name.
2633 - As a hexadecimal code point, e.g. 263A. Note that code points in
2634 Emacs are equivalent to Unicode up to 10FFFF (which is the limit of
2635 the Unicode code space).
2637 - As a code point with a radix specified with #, e.g. #o21430
2638 (octal), #x2318 (hex), or #10r8984 (decimal).
2640 If called interactively, COUNT is given by the prefix argument. If
2641 omitted or nil, it defaults to 1.
2643 Inserting the character(s) relocates point and before-insertion
2644 markers in the same ways as the function `insert'.
2646 The optional third argument INHERIT, if non-nil, says to inherit text
2647 properties from adjoining text, if those properties are sticky. If
2648 called interactively, INHERIT is t. */)
2649 (Lisp_Object character, Lisp_Object count, Lisp_Object inherit)
2651 int i, stringlen;
2652 register ptrdiff_t n;
2653 int c, len;
2654 unsigned char str[MAX_MULTIBYTE_LENGTH];
2655 char string[4000];
2657 CHECK_CHARACTER (character);
2658 if (NILP (count))
2659 XSETFASTINT (count, 1);
2660 CHECK_NUMBER (count);
2661 c = XFASTINT (character);
2663 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2664 len = CHAR_STRING (c, str);
2665 else
2666 str[0] = c, len = 1;
2667 if (XINT (count) <= 0)
2668 return Qnil;
2669 if (BUF_BYTES_MAX / len < XINT (count))
2670 buffer_overflow ();
2671 n = XINT (count) * len;
2672 stringlen = min (n, sizeof string - sizeof string % len);
2673 for (i = 0; i < stringlen; i++)
2674 string[i] = str[i % len];
2675 while (n > stringlen)
2677 QUIT;
2678 if (!NILP (inherit))
2679 insert_and_inherit (string, stringlen);
2680 else
2681 insert (string, stringlen);
2682 n -= stringlen;
2684 if (!NILP (inherit))
2685 insert_and_inherit (string, n);
2686 else
2687 insert (string, n);
2688 return Qnil;
2691 DEFUN ("insert-byte", Finsert_byte, Sinsert_byte, 2, 3, 0,
2692 doc: /* Insert COUNT (second arg) copies of BYTE (first arg).
2693 Both arguments are required.
2694 BYTE is a number of the range 0..255.
2696 If BYTE is 128..255 and the current buffer is multibyte, the
2697 corresponding eight-bit character is inserted.
2699 Point, and before-insertion markers, are relocated as in the function `insert'.
2700 The optional third arg INHERIT, if non-nil, says to inherit text properties
2701 from adjoining text, if those properties are sticky. */)
2702 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
2704 CHECK_NUMBER (byte);
2705 if (XINT (byte) < 0 || XINT (byte) > 255)
2706 args_out_of_range_3 (byte, make_number (0), make_number (255));
2707 if (XINT (byte) >= 128
2708 && ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2709 XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte)));
2710 return Finsert_char (byte, count, inherit);
2714 /* Making strings from buffer contents. */
2716 /* Return a Lisp_String containing the text of the current buffer from
2717 START to END. If text properties are in use and the current buffer
2718 has properties in the range specified, the resulting string will also
2719 have them, if PROPS is true.
2721 We don't want to use plain old make_string here, because it calls
2722 make_uninit_string, which can cause the buffer arena to be
2723 compacted. make_string has no way of knowing that the data has
2724 been moved, and thus copies the wrong data into the string. This
2725 doesn't effect most of the other users of make_string, so it should
2726 be left as is. But we should use this function when conjuring
2727 buffer substrings. */
2729 Lisp_Object
2730 make_buffer_string (ptrdiff_t start, ptrdiff_t end, bool props)
2732 ptrdiff_t start_byte = CHAR_TO_BYTE (start);
2733 ptrdiff_t end_byte = CHAR_TO_BYTE (end);
2735 return make_buffer_string_both (start, start_byte, end, end_byte, props);
2738 /* Return a Lisp_String containing the text of the current buffer from
2739 START / START_BYTE to END / END_BYTE.
2741 If text properties are in use and the current buffer
2742 has properties in the range specified, the resulting string will also
2743 have them, if PROPS is true.
2745 We don't want to use plain old make_string here, because it calls
2746 make_uninit_string, which can cause the buffer arena to be
2747 compacted. make_string has no way of knowing that the data has
2748 been moved, and thus copies the wrong data into the string. This
2749 doesn't effect most of the other users of make_string, so it should
2750 be left as is. But we should use this function when conjuring
2751 buffer substrings. */
2753 Lisp_Object
2754 make_buffer_string_both (ptrdiff_t start, ptrdiff_t start_byte,
2755 ptrdiff_t end, ptrdiff_t end_byte, bool props)
2757 Lisp_Object result, tem, tem1;
2758 ptrdiff_t beg0, end0, beg1, end1, size;
2760 if (start_byte < GPT_BYTE && GPT_BYTE < end_byte)
2762 /* Two regions, before and after the gap. */
2763 beg0 = start_byte;
2764 end0 = GPT_BYTE;
2765 beg1 = GPT_BYTE + GAP_SIZE - BEG_BYTE;
2766 end1 = end_byte + GAP_SIZE - BEG_BYTE;
2768 else
2770 /* The only region. */
2771 beg0 = start_byte;
2772 end0 = end_byte;
2773 beg1 = -1;
2774 end1 = -1;
2777 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2778 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
2779 else
2780 result = make_uninit_string (end - start);
2782 size = end0 - beg0;
2783 memcpy (SDATA (result), BYTE_POS_ADDR (beg0), size);
2784 if (beg1 != -1)
2785 memcpy (SDATA (result) + size, BEG_ADDR + beg1, end1 - beg1);
2787 /* If desired, update and copy the text properties. */
2788 if (props)
2790 update_buffer_properties (start, end);
2792 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
2793 tem1 = Ftext_properties_at (make_number (start), Qnil);
2795 if (XINT (tem) != end || !NILP (tem1))
2796 copy_intervals_to_string (result, current_buffer, start,
2797 end - start);
2800 return result;
2803 /* Call Vbuffer_access_fontify_functions for the range START ... END
2804 in the current buffer, if necessary. */
2806 static void
2807 update_buffer_properties (ptrdiff_t start, ptrdiff_t end)
2809 /* If this buffer has some access functions,
2810 call them, specifying the range of the buffer being accessed. */
2811 if (!NILP (Vbuffer_access_fontify_functions))
2813 /* But don't call them if we can tell that the work
2814 has already been done. */
2815 if (!NILP (Vbuffer_access_fontified_property))
2817 Lisp_Object tem
2818 = Ftext_property_any (make_number (start), make_number (end),
2819 Vbuffer_access_fontified_property,
2820 Qnil, Qnil);
2821 if (NILP (tem))
2822 return;
2825 CALLN (Frun_hook_with_args, Qbuffer_access_fontify_functions,
2826 make_number (start), make_number (end));
2830 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
2831 doc: /* Return the contents of part of the current buffer as a string.
2832 The two arguments START and END are character positions;
2833 they can be in either order.
2834 The string returned is multibyte if the buffer is multibyte.
2836 This function copies the text properties of that part of the buffer
2837 into the result string; if you don't want the text properties,
2838 use `buffer-substring-no-properties' instead. */)
2839 (Lisp_Object start, Lisp_Object end)
2841 register ptrdiff_t b, e;
2843 validate_region (&start, &end);
2844 b = XINT (start);
2845 e = XINT (end);
2847 return make_buffer_string (b, e, 1);
2850 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
2851 Sbuffer_substring_no_properties, 2, 2, 0,
2852 doc: /* Return the characters of part of the buffer, without the text properties.
2853 The two arguments START and END are character positions;
2854 they can be in either order. */)
2855 (Lisp_Object start, Lisp_Object end)
2857 register ptrdiff_t b, e;
2859 validate_region (&start, &end);
2860 b = XINT (start);
2861 e = XINT (end);
2863 return make_buffer_string (b, e, 0);
2866 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
2867 doc: /* Return the contents of the current buffer as a string.
2868 If narrowing is in effect, this function returns only the visible part
2869 of the buffer. */)
2870 (void)
2872 return make_buffer_string_both (BEGV, BEGV_BYTE, ZV, ZV_BYTE, 1);
2875 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
2876 1, 3, 0,
2877 doc: /* Insert before point a substring of the contents of BUFFER.
2878 BUFFER may be a buffer or a buffer name.
2879 Arguments START and END are character positions specifying the substring.
2880 They default to the values of (point-min) and (point-max) in BUFFER.
2882 Point and before-insertion markers move forward to end up after the
2883 inserted text.
2884 Any other markers at the point of insertion remain before the text.
2886 If the current buffer is multibyte and BUFFER is unibyte, or vice
2887 versa, strings are converted from unibyte to multibyte or vice versa
2888 using `string-make-multibyte' or `string-make-unibyte', which see. */)
2889 (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
2891 register EMACS_INT b, e, temp;
2892 register struct buffer *bp, *obuf;
2893 Lisp_Object buf;
2895 buf = Fget_buffer (buffer);
2896 if (NILP (buf))
2897 nsberror (buffer);
2898 bp = XBUFFER (buf);
2899 if (!BUFFER_LIVE_P (bp))
2900 error ("Selecting deleted buffer");
2902 if (NILP (start))
2903 b = BUF_BEGV (bp);
2904 else
2906 CHECK_NUMBER_COERCE_MARKER (start);
2907 b = XINT (start);
2909 if (NILP (end))
2910 e = BUF_ZV (bp);
2911 else
2913 CHECK_NUMBER_COERCE_MARKER (end);
2914 e = XINT (end);
2917 if (b > e)
2918 temp = b, b = e, e = temp;
2920 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
2921 args_out_of_range (start, end);
2923 obuf = current_buffer;
2924 set_buffer_internal_1 (bp);
2925 update_buffer_properties (b, e);
2926 set_buffer_internal_1 (obuf);
2928 insert_from_buffer (bp, b, e - b, 0);
2929 return Qnil;
2932 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
2933 6, 6, 0,
2934 doc: /* Compare two substrings of two buffers; return result as number.
2935 Return -N if first string is less after N-1 chars, +N if first string is
2936 greater after N-1 chars, or 0 if strings match.
2937 The first substring is in BUFFER1 from START1 to END1 and the second
2938 is in BUFFER2 from START2 to END2.
2939 The value of `case-fold-search' in the current buffer
2940 determines whether case is significant or ignored. */)
2941 (Lisp_Object buffer1, Lisp_Object start1, Lisp_Object end1, Lisp_Object buffer2, Lisp_Object start2, Lisp_Object end2)
2943 register EMACS_INT begp1, endp1, begp2, endp2, temp;
2944 register struct buffer *bp1, *bp2;
2945 register Lisp_Object trt
2946 = (!NILP (BVAR (current_buffer, case_fold_search))
2947 ? BVAR (current_buffer, case_canon_table) : Qnil);
2948 ptrdiff_t chars = 0;
2949 ptrdiff_t i1, i2, i1_byte, i2_byte;
2951 /* Find the first buffer and its substring. */
2953 if (NILP (buffer1))
2954 bp1 = current_buffer;
2955 else
2957 Lisp_Object buf1;
2958 buf1 = Fget_buffer (buffer1);
2959 if (NILP (buf1))
2960 nsberror (buffer1);
2961 bp1 = XBUFFER (buf1);
2962 if (!BUFFER_LIVE_P (bp1))
2963 error ("Selecting deleted buffer");
2966 if (NILP (start1))
2967 begp1 = BUF_BEGV (bp1);
2968 else
2970 CHECK_NUMBER_COERCE_MARKER (start1);
2971 begp1 = XINT (start1);
2973 if (NILP (end1))
2974 endp1 = BUF_ZV (bp1);
2975 else
2977 CHECK_NUMBER_COERCE_MARKER (end1);
2978 endp1 = XINT (end1);
2981 if (begp1 > endp1)
2982 temp = begp1, begp1 = endp1, endp1 = temp;
2984 if (!(BUF_BEGV (bp1) <= begp1
2985 && begp1 <= endp1
2986 && endp1 <= BUF_ZV (bp1)))
2987 args_out_of_range (start1, end1);
2989 /* Likewise for second substring. */
2991 if (NILP (buffer2))
2992 bp2 = current_buffer;
2993 else
2995 Lisp_Object buf2;
2996 buf2 = Fget_buffer (buffer2);
2997 if (NILP (buf2))
2998 nsberror (buffer2);
2999 bp2 = XBUFFER (buf2);
3000 if (!BUFFER_LIVE_P (bp2))
3001 error ("Selecting deleted buffer");
3004 if (NILP (start2))
3005 begp2 = BUF_BEGV (bp2);
3006 else
3008 CHECK_NUMBER_COERCE_MARKER (start2);
3009 begp2 = XINT (start2);
3011 if (NILP (end2))
3012 endp2 = BUF_ZV (bp2);
3013 else
3015 CHECK_NUMBER_COERCE_MARKER (end2);
3016 endp2 = XINT (end2);
3019 if (begp2 > endp2)
3020 temp = begp2, begp2 = endp2, endp2 = temp;
3022 if (!(BUF_BEGV (bp2) <= begp2
3023 && begp2 <= endp2
3024 && endp2 <= BUF_ZV (bp2)))
3025 args_out_of_range (start2, end2);
3027 i1 = begp1;
3028 i2 = begp2;
3029 i1_byte = buf_charpos_to_bytepos (bp1, i1);
3030 i2_byte = buf_charpos_to_bytepos (bp2, i2);
3032 while (i1 < endp1 && i2 < endp2)
3034 /* When we find a mismatch, we must compare the
3035 characters, not just the bytes. */
3036 int c1, c2;
3038 QUIT;
3040 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
3042 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
3043 BUF_INC_POS (bp1, i1_byte);
3044 i1++;
3046 else
3048 c1 = BUF_FETCH_BYTE (bp1, i1);
3049 MAKE_CHAR_MULTIBYTE (c1);
3050 i1++;
3053 if (! NILP (BVAR (bp2, enable_multibyte_characters)))
3055 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
3056 BUF_INC_POS (bp2, i2_byte);
3057 i2++;
3059 else
3061 c2 = BUF_FETCH_BYTE (bp2, i2);
3062 MAKE_CHAR_MULTIBYTE (c2);
3063 i2++;
3066 if (!NILP (trt))
3068 c1 = char_table_translate (trt, c1);
3069 c2 = char_table_translate (trt, c2);
3071 if (c1 < c2)
3072 return make_number (- 1 - chars);
3073 if (c1 > c2)
3074 return make_number (chars + 1);
3076 chars++;
3079 /* The strings match as far as they go.
3080 If one is shorter, that one is less. */
3081 if (chars < endp1 - begp1)
3082 return make_number (chars + 1);
3083 else if (chars < endp2 - begp2)
3084 return make_number (- chars - 1);
3086 /* Same length too => they are equal. */
3087 return make_number (0);
3090 static void
3091 subst_char_in_region_unwind (Lisp_Object arg)
3093 bset_undo_list (current_buffer, arg);
3096 static void
3097 subst_char_in_region_unwind_1 (Lisp_Object arg)
3099 bset_filename (current_buffer, arg);
3102 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
3103 Ssubst_char_in_region, 4, 5, 0,
3104 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
3105 If optional arg NOUNDO is non-nil, don't record this change for undo
3106 and don't mark the buffer as really changed.
3107 Both characters must have the same length of multi-byte form. */)
3108 (Lisp_Object start, Lisp_Object end, Lisp_Object fromchar, Lisp_Object tochar, Lisp_Object noundo)
3110 register ptrdiff_t pos, pos_byte, stop, i, len, end_byte;
3111 /* Keep track of the first change in the buffer:
3112 if 0 we haven't found it yet.
3113 if < 0 we've found it and we've run the before-change-function.
3114 if > 0 we've actually performed it and the value is its position. */
3115 ptrdiff_t changed = 0;
3116 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
3117 unsigned char *p;
3118 ptrdiff_t count = SPECPDL_INDEX ();
3119 #define COMBINING_NO 0
3120 #define COMBINING_BEFORE 1
3121 #define COMBINING_AFTER 2
3122 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
3123 int maybe_byte_combining = COMBINING_NO;
3124 ptrdiff_t last_changed = 0;
3125 bool multibyte_p
3126 = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3127 int fromc, toc;
3129 restart:
3131 validate_region (&start, &end);
3132 CHECK_CHARACTER (fromchar);
3133 CHECK_CHARACTER (tochar);
3134 fromc = XFASTINT (fromchar);
3135 toc = XFASTINT (tochar);
3137 if (multibyte_p)
3139 len = CHAR_STRING (fromc, fromstr);
3140 if (CHAR_STRING (toc, tostr) != len)
3141 error ("Characters in `subst-char-in-region' have different byte-lengths");
3142 if (!ASCII_CHAR_P (*tostr))
3144 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
3145 complete multibyte character, it may be combined with the
3146 after bytes. If it is in the range 0xA0..0xFF, it may be
3147 combined with the before and after bytes. */
3148 if (!CHAR_HEAD_P (*tostr))
3149 maybe_byte_combining = COMBINING_BOTH;
3150 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
3151 maybe_byte_combining = COMBINING_AFTER;
3154 else
3156 len = 1;
3157 fromstr[0] = fromc;
3158 tostr[0] = toc;
3161 pos = XINT (start);
3162 pos_byte = CHAR_TO_BYTE (pos);
3163 stop = CHAR_TO_BYTE (XINT (end));
3164 end_byte = stop;
3166 /* If we don't want undo, turn off putting stuff on the list.
3167 That's faster than getting rid of things,
3168 and it prevents even the entry for a first change.
3169 Also inhibit locking the file. */
3170 if (!changed && !NILP (noundo))
3172 record_unwind_protect (subst_char_in_region_unwind,
3173 BVAR (current_buffer, undo_list));
3174 bset_undo_list (current_buffer, Qt);
3175 /* Don't do file-locking. */
3176 record_unwind_protect (subst_char_in_region_unwind_1,
3177 BVAR (current_buffer, filename));
3178 bset_filename (current_buffer, Qnil);
3181 if (pos_byte < GPT_BYTE)
3182 stop = min (stop, GPT_BYTE);
3183 while (1)
3185 ptrdiff_t pos_byte_next = pos_byte;
3187 if (pos_byte >= stop)
3189 if (pos_byte >= end_byte) break;
3190 stop = end_byte;
3192 p = BYTE_POS_ADDR (pos_byte);
3193 if (multibyte_p)
3194 INC_POS (pos_byte_next);
3195 else
3196 ++pos_byte_next;
3197 if (pos_byte_next - pos_byte == len
3198 && p[0] == fromstr[0]
3199 && (len == 1
3200 || (p[1] == fromstr[1]
3201 && (len == 2 || (p[2] == fromstr[2]
3202 && (len == 3 || p[3] == fromstr[3]))))))
3204 if (changed < 0)
3205 /* We've already seen this and run the before-change-function;
3206 this time we only need to record the actual position. */
3207 changed = pos;
3208 else if (!changed)
3210 changed = -1;
3211 modify_text (pos, XINT (end));
3213 if (! NILP (noundo))
3215 if (MODIFF - 1 == SAVE_MODIFF)
3216 SAVE_MODIFF++;
3217 if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer))
3218 BUF_AUTOSAVE_MODIFF (current_buffer)++;
3221 /* The before-change-function may have moved the gap
3222 or even modified the buffer so we should start over. */
3223 goto restart;
3226 /* Take care of the case where the new character
3227 combines with neighboring bytes. */
3228 if (maybe_byte_combining
3229 && (maybe_byte_combining == COMBINING_AFTER
3230 ? (pos_byte_next < Z_BYTE
3231 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
3232 : ((pos_byte_next < Z_BYTE
3233 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
3234 || (pos_byte > BEG_BYTE
3235 && ! ASCII_CHAR_P (FETCH_BYTE (pos_byte - 1))))))
3237 Lisp_Object tem, string;
3239 tem = BVAR (current_buffer, undo_list);
3241 /* Make a multibyte string containing this single character. */
3242 string = make_multibyte_string ((char *) tostr, 1, len);
3243 /* replace_range is less efficient, because it moves the gap,
3244 but it handles combining correctly. */
3245 replace_range (pos, pos + 1, string,
3246 0, 0, 1);
3247 pos_byte_next = CHAR_TO_BYTE (pos);
3248 if (pos_byte_next > pos_byte)
3249 /* Before combining happened. We should not increment
3250 POS. So, to cancel the later increment of POS,
3251 decrease it now. */
3252 pos--;
3253 else
3254 INC_POS (pos_byte_next);
3256 if (! NILP (noundo))
3257 bset_undo_list (current_buffer, tem);
3259 else
3261 if (NILP (noundo))
3262 record_change (pos, 1);
3263 for (i = 0; i < len; i++) *p++ = tostr[i];
3265 last_changed = pos + 1;
3267 pos_byte = pos_byte_next;
3268 pos++;
3271 if (changed > 0)
3273 signal_after_change (changed,
3274 last_changed - changed, last_changed - changed);
3275 update_compositions (changed, last_changed, CHECK_ALL);
3278 unbind_to (count, Qnil);
3279 return Qnil;
3283 static Lisp_Object check_translation (ptrdiff_t, ptrdiff_t, ptrdiff_t,
3284 Lisp_Object);
3286 /* Helper function for Ftranslate_region_internal.
3288 Check if a character sequence at POS (POS_BYTE) matches an element
3289 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
3290 element is found, return it. Otherwise return Qnil. */
3292 static Lisp_Object
3293 check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end,
3294 Lisp_Object val)
3296 int initial_buf[16];
3297 int *buf = initial_buf;
3298 ptrdiff_t buf_size = ARRAYELTS (initial_buf);
3299 int *bufalloc = 0;
3300 ptrdiff_t buf_used = 0;
3301 Lisp_Object result = Qnil;
3303 for (; CONSP (val); val = XCDR (val))
3305 Lisp_Object elt;
3306 ptrdiff_t len, i;
3308 elt = XCAR (val);
3309 if (! CONSP (elt))
3310 continue;
3311 elt = XCAR (elt);
3312 if (! VECTORP (elt))
3313 continue;
3314 len = ASIZE (elt);
3315 if (len <= end - pos)
3317 for (i = 0; i < len; i++)
3319 if (buf_used <= i)
3321 unsigned char *p = BYTE_POS_ADDR (pos_byte);
3322 int len1;
3324 if (buf_used == buf_size)
3326 bufalloc = xpalloc (bufalloc, &buf_size, 1, -1,
3327 sizeof *bufalloc);
3328 if (buf == initial_buf)
3329 memcpy (bufalloc, buf, sizeof initial_buf);
3330 buf = bufalloc;
3332 buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1);
3333 pos_byte += len1;
3335 if (XINT (AREF (elt, i)) != buf[i])
3336 break;
3338 if (i == len)
3340 result = XCAR (val);
3341 break;
3346 xfree (bufalloc);
3347 return result;
3351 DEFUN ("translate-region-internal", Ftranslate_region_internal,
3352 Stranslate_region_internal, 3, 3, 0,
3353 doc: /* Internal use only.
3354 From START to END, translate characters according to TABLE.
3355 TABLE is a string or a char-table; the Nth character in it is the
3356 mapping for the character with code N.
3357 It returns the number of characters changed. */)
3358 (Lisp_Object start, Lisp_Object end, register Lisp_Object table)
3360 register unsigned char *tt; /* Trans table. */
3361 register int nc; /* New character. */
3362 int cnt; /* Number of changes made. */
3363 ptrdiff_t size; /* Size of translate table. */
3364 ptrdiff_t pos, pos_byte, end_pos;
3365 bool multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3366 bool string_multibyte IF_LINT (= 0);
3368 validate_region (&start, &end);
3369 if (CHAR_TABLE_P (table))
3371 if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
3372 error ("Not a translation table");
3373 size = MAX_CHAR;
3374 tt = NULL;
3376 else
3378 CHECK_STRING (table);
3380 if (! multibyte && (SCHARS (table) < SBYTES (table)))
3381 table = string_make_unibyte (table);
3382 string_multibyte = SCHARS (table) < SBYTES (table);
3383 size = SBYTES (table);
3384 tt = SDATA (table);
3387 pos = XINT (start);
3388 pos_byte = CHAR_TO_BYTE (pos);
3389 end_pos = XINT (end);
3390 modify_text (pos, end_pos);
3392 cnt = 0;
3393 for (; pos < end_pos; )
3395 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
3396 unsigned char *str, buf[MAX_MULTIBYTE_LENGTH];
3397 int len, str_len;
3398 int oc;
3399 Lisp_Object val;
3401 if (multibyte)
3402 oc = STRING_CHAR_AND_LENGTH (p, len);
3403 else
3404 oc = *p, len = 1;
3405 if (oc < size)
3407 if (tt)
3409 /* Reload as signal_after_change in last iteration may GC. */
3410 tt = SDATA (table);
3411 if (string_multibyte)
3413 str = tt + string_char_to_byte (table, oc);
3414 nc = STRING_CHAR_AND_LENGTH (str, str_len);
3416 else
3418 nc = tt[oc];
3419 if (! ASCII_CHAR_P (nc) && multibyte)
3421 str_len = BYTE8_STRING (nc, buf);
3422 str = buf;
3424 else
3426 str_len = 1;
3427 str = tt + oc;
3431 else
3433 nc = oc;
3434 val = CHAR_TABLE_REF (table, oc);
3435 if (CHARACTERP (val))
3437 nc = XFASTINT (val);
3438 str_len = CHAR_STRING (nc, buf);
3439 str = buf;
3441 else if (VECTORP (val) || (CONSP (val)))
3443 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3444 where TO is TO-CHAR or [TO-CHAR ...]. */
3445 nc = -1;
3449 if (nc != oc && nc >= 0)
3451 /* Simple one char to one char translation. */
3452 if (len != str_len)
3454 Lisp_Object string;
3456 /* This is less efficient, because it moves the gap,
3457 but it should handle multibyte characters correctly. */
3458 string = make_multibyte_string ((char *) str, 1, str_len);
3459 replace_range (pos, pos + 1, string, 1, 0, 1);
3460 len = str_len;
3462 else
3464 record_change (pos, 1);
3465 while (str_len-- > 0)
3466 *p++ = *str++;
3467 signal_after_change (pos, 1, 1);
3468 update_compositions (pos, pos + 1, CHECK_BORDER);
3470 ++cnt;
3472 else if (nc < 0)
3474 Lisp_Object string;
3476 if (CONSP (val))
3478 val = check_translation (pos, pos_byte, end_pos, val);
3479 if (NILP (val))
3481 pos_byte += len;
3482 pos++;
3483 continue;
3485 /* VAL is ([FROM-CHAR ...] . TO). */
3486 len = ASIZE (XCAR (val));
3487 val = XCDR (val);
3489 else
3490 len = 1;
3492 if (VECTORP (val))
3494 string = Fconcat (1, &val);
3496 else
3498 string = Fmake_string (make_number (1), val);
3500 replace_range (pos, pos + len, string, 1, 0, 1);
3501 pos_byte += SBYTES (string);
3502 pos += SCHARS (string);
3503 cnt += SCHARS (string);
3504 end_pos += SCHARS (string) - len;
3505 continue;
3508 pos_byte += len;
3509 pos++;
3512 return make_number (cnt);
3515 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
3516 doc: /* Delete the text between START and END.
3517 If called interactively, delete the region between point and mark.
3518 This command deletes buffer text without modifying the kill ring. */)
3519 (Lisp_Object start, Lisp_Object end)
3521 validate_region (&start, &end);
3522 del_range (XINT (start), XINT (end));
3523 return Qnil;
3526 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
3527 Sdelete_and_extract_region, 2, 2, 0,
3528 doc: /* Delete the text between START and END and return it. */)
3529 (Lisp_Object start, Lisp_Object end)
3531 validate_region (&start, &end);
3532 if (XINT (start) == XINT (end))
3533 return empty_unibyte_string;
3534 return del_range_1 (XINT (start), XINT (end), 1, 1);
3537 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
3538 doc: /* Remove restrictions (narrowing) from current buffer.
3539 This allows the buffer's full text to be seen and edited. */)
3540 (void)
3542 if (BEG != BEGV || Z != ZV)
3543 current_buffer->clip_changed = 1;
3544 BEGV = BEG;
3545 BEGV_BYTE = BEG_BYTE;
3546 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
3547 /* Changing the buffer bounds invalidates any recorded current column. */
3548 invalidate_current_column ();
3549 return Qnil;
3552 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
3553 doc: /* Restrict editing in this buffer to the current region.
3554 The rest of the text becomes temporarily invisible and untouchable
3555 but is not deleted; if you save the buffer in a file, the invisible
3556 text is included in the file. \\[widen] makes all visible again.
3557 See also `save-restriction'.
3559 When calling from a program, pass two arguments; positions (integers
3560 or markers) bounding the text that should remain visible. */)
3561 (register Lisp_Object start, Lisp_Object end)
3563 CHECK_NUMBER_COERCE_MARKER (start);
3564 CHECK_NUMBER_COERCE_MARKER (end);
3566 if (XINT (start) > XINT (end))
3568 Lisp_Object tem;
3569 tem = start; start = end; end = tem;
3572 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
3573 args_out_of_range (start, end);
3575 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
3576 current_buffer->clip_changed = 1;
3578 SET_BUF_BEGV (current_buffer, XFASTINT (start));
3579 SET_BUF_ZV (current_buffer, XFASTINT (end));
3580 if (PT < XFASTINT (start))
3581 SET_PT (XFASTINT (start));
3582 if (PT > XFASTINT (end))
3583 SET_PT (XFASTINT (end));
3584 /* Changing the buffer bounds invalidates any recorded current column. */
3585 invalidate_current_column ();
3586 return Qnil;
3589 Lisp_Object
3590 save_restriction_save (void)
3592 if (BEGV == BEG && ZV == Z)
3593 /* The common case that the buffer isn't narrowed.
3594 We return just the buffer object, which save_restriction_restore
3595 recognizes as meaning `no restriction'. */
3596 return Fcurrent_buffer ();
3597 else
3598 /* We have to save a restriction, so return a pair of markers, one
3599 for the beginning and one for the end. */
3601 Lisp_Object beg, end;
3603 beg = build_marker (current_buffer, BEGV, BEGV_BYTE);
3604 end = build_marker (current_buffer, ZV, ZV_BYTE);
3606 /* END must move forward if text is inserted at its exact location. */
3607 XMARKER (end)->insertion_type = 1;
3609 return Fcons (beg, end);
3613 void
3614 save_restriction_restore (Lisp_Object data)
3616 struct buffer *cur = NULL;
3617 struct buffer *buf = (CONSP (data)
3618 ? XMARKER (XCAR (data))->buffer
3619 : XBUFFER (data));
3621 if (buf && buf != current_buffer && !NILP (BVAR (buf, pt_marker)))
3622 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3623 is the case if it is or has an indirect buffer), then make
3624 sure it is current before we update BEGV, so
3625 set_buffer_internal takes care of managing those markers. */
3626 cur = current_buffer;
3627 set_buffer_internal (buf);
3630 if (CONSP (data))
3631 /* A pair of marks bounding a saved restriction. */
3633 struct Lisp_Marker *beg = XMARKER (XCAR (data));
3634 struct Lisp_Marker *end = XMARKER (XCDR (data));
3635 eassert (buf == end->buffer);
3637 if (buf /* Verify marker still points to a buffer. */
3638 && (beg->charpos != BUF_BEGV (buf) || end->charpos != BUF_ZV (buf)))
3639 /* The restriction has changed from the saved one, so restore
3640 the saved restriction. */
3642 ptrdiff_t pt = BUF_PT (buf);
3644 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
3645 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
3647 if (pt < beg->charpos || pt > end->charpos)
3648 /* The point is outside the new visible range, move it inside. */
3649 SET_BUF_PT_BOTH (buf,
3650 clip_to_bounds (beg->charpos, pt, end->charpos),
3651 clip_to_bounds (beg->bytepos, BUF_PT_BYTE (buf),
3652 end->bytepos));
3654 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3656 /* These aren't needed anymore, so don't wait for GC. */
3657 free_marker (XCAR (data));
3658 free_marker (XCDR (data));
3659 free_cons (XCONS (data));
3661 else
3662 /* A buffer, which means that there was no old restriction. */
3664 if (buf /* Verify marker still points to a buffer. */
3665 && (BUF_BEGV (buf) != BUF_BEG (buf) || BUF_ZV (buf) != BUF_Z (buf)))
3666 /* The buffer has been narrowed, get rid of the narrowing. */
3668 SET_BUF_BEGV_BOTH (buf, BUF_BEG (buf), BUF_BEG_BYTE (buf));
3669 SET_BUF_ZV_BOTH (buf, BUF_Z (buf), BUF_Z_BYTE (buf));
3671 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3675 /* Changing the buffer bounds invalidates any recorded current column. */
3676 invalidate_current_column ();
3678 if (cur)
3679 set_buffer_internal (cur);
3682 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
3683 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
3684 The buffer's restrictions make parts of the beginning and end invisible.
3685 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3686 This special form, `save-restriction', saves the current buffer's restrictions
3687 when it is entered, and restores them when it is exited.
3688 So any `narrow-to-region' within BODY lasts only until the end of the form.
3689 The old restrictions settings are restored
3690 even in case of abnormal exit (throw or error).
3692 The value returned is the value of the last form in BODY.
3694 Note: if you are using both `save-excursion' and `save-restriction',
3695 use `save-excursion' outermost:
3696 (save-excursion (save-restriction ...))
3698 usage: (save-restriction &rest BODY) */)
3699 (Lisp_Object body)
3701 register Lisp_Object val;
3702 ptrdiff_t count = SPECPDL_INDEX ();
3704 record_unwind_protect (save_restriction_restore, save_restriction_save ());
3705 val = Fprogn (body);
3706 return unbind_to (count, val);
3709 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
3710 doc: /* Display a message at the bottom of the screen.
3711 The message also goes into the `*Messages*' buffer, if `message-log-max'
3712 is non-nil. (In keyboard macros, that's all it does.)
3713 Return the message.
3715 In batch mode, the message is printed to the standard error stream,
3716 followed by a newline.
3718 The first argument is a format control string, and the rest are data
3719 to be formatted under control of the string. See `format-message' for
3720 details.
3722 Note: (message "%s" VALUE) displays the string VALUE without
3723 interpreting format characters like `%', `\\=`', and `\\=''.
3725 If the first argument is nil or the empty string, the function clears
3726 any existing message; this lets the minibuffer contents show. See
3727 also `current-message'.
3729 usage: (message FORMAT-STRING &rest ARGS) */)
3730 (ptrdiff_t nargs, Lisp_Object *args)
3732 if (NILP (args[0])
3733 || (STRINGP (args[0])
3734 && SBYTES (args[0]) == 0))
3736 message1 (0);
3737 return args[0];
3739 else
3741 Lisp_Object val = Fformat_message (nargs, args);
3742 message3 (val);
3743 return val;
3747 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
3748 doc: /* Display a message, in a dialog box if possible.
3749 If a dialog box is not available, use the echo area.
3750 The first argument is a format control string, and the rest are data
3751 to be formatted under control of the string. See `format-message' for
3752 details.
3754 If the first argument is nil or the empty string, clear any existing
3755 message; let the minibuffer contents show.
3757 usage: (message-box FORMAT-STRING &rest ARGS) */)
3758 (ptrdiff_t nargs, Lisp_Object *args)
3760 if (NILP (args[0]))
3762 message1 (0);
3763 return Qnil;
3765 else
3767 Lisp_Object val = Fformat_message (nargs, args);
3768 Lisp_Object pane, menu;
3770 pane = list1 (Fcons (build_string ("OK"), Qt));
3771 menu = Fcons (val, pane);
3772 Fx_popup_dialog (Qt, menu, Qt);
3773 return val;
3777 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
3778 doc: /* Display a message in a dialog box or in the echo area.
3779 If this command was invoked with the mouse, use a dialog box if
3780 `use-dialog-box' is non-nil.
3781 Otherwise, use the echo area.
3782 The first argument is a format control string, and the rest are data
3783 to be formatted under control of the string. See `format-message' for
3784 details.
3786 If the first argument is nil or the empty string, clear any existing
3787 message; let the minibuffer contents show.
3789 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3790 (ptrdiff_t nargs, Lisp_Object *args)
3792 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
3793 && use_dialog_box)
3794 return Fmessage_box (nargs, args);
3795 return Fmessage (nargs, args);
3798 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
3799 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
3800 (void)
3802 return current_message ();
3806 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
3807 doc: /* Return a copy of STRING with text properties added.
3808 First argument is the string to copy.
3809 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3810 properties to add to the result.
3811 usage: (propertize STRING &rest PROPERTIES) */)
3812 (ptrdiff_t nargs, Lisp_Object *args)
3814 Lisp_Object properties, string;
3815 ptrdiff_t i;
3817 /* Number of args must be odd. */
3818 if ((nargs & 1) == 0)
3819 error ("Wrong number of arguments");
3821 properties = string = Qnil;
3823 /* First argument must be a string. */
3824 CHECK_STRING (args[0]);
3825 string = Fcopy_sequence (args[0]);
3827 for (i = 1; i < nargs; i += 2)
3828 properties = Fcons (args[i], Fcons (args[i + 1], properties));
3830 Fadd_text_properties (make_number (0),
3831 make_number (SCHARS (string)),
3832 properties, string);
3833 return string;
3836 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
3837 doc: /* Format a string out of a format-string and arguments.
3838 The first argument is a format control string.
3839 The other arguments are substituted into it to make the result, a string.
3841 The format control string may contain %-sequences meaning to substitute
3842 the next available argument:
3844 %s means print a string argument. Actually, prints any object, with `princ'.
3845 %d means print as number in decimal (%o octal, %x hex).
3846 %X is like %x, but uses upper case.
3847 %e means print a number in exponential notation.
3848 %f means print a number in decimal-point notation.
3849 %g means print a number in exponential notation
3850 or decimal-point notation, whichever uses fewer characters.
3851 %c means print a number as a single character.
3852 %S means print any object as an s-expression (using `prin1').
3854 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3855 Use %% to put a single % into the output.
3857 A %-sequence may contain optional flag, width, and precision
3858 specifiers, as follows:
3860 %<flags><width><precision>character
3862 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3864 The + flag character inserts a + before any positive number, while a
3865 space inserts a space before any positive number; these flags only
3866 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3867 The - and 0 flags affect the width specifier, as described below.
3869 The # flag means to use an alternate display form for %o, %x, %X, %e,
3870 %f, and %g sequences: for %o, it ensures that the result begins with
3871 \"0\"; for %x and %X, it prefixes the result with \"0x\" or \"0X\";
3872 for %e, %f, and %g, it causes a decimal point to be included even if
3873 the precision is zero.
3875 The width specifier supplies a lower limit for the length of the
3876 printed representation. The padding, if any, normally goes on the
3877 left, but it goes on the right if the - flag is present. The padding
3878 character is normally a space, but it is 0 if the 0 flag is present.
3879 The 0 flag is ignored if the - flag is present, or the format sequence
3880 is something other than %d, %e, %f, and %g.
3882 For %e, %f, and %g sequences, the number after the "." in the
3883 precision specifier says how many decimal places to show; if zero, the
3884 decimal point itself is omitted. For %s and %S, the precision
3885 specifier truncates the string to the given width.
3887 usage: (format STRING &rest OBJECTS) */)
3888 (ptrdiff_t nargs, Lisp_Object *args)
3890 return styled_format (nargs, args, false);
3893 DEFUN ("format-message", Fformat_message, Sformat_message, 1, MANY, 0,
3894 doc: /* Format a string out of a format-string and arguments.
3895 The first argument is a format control string.
3896 The other arguments are substituted into it to make the result, a string.
3898 This acts like `format', except it also replaces each left single
3899 quotation mark (\\=‘) and grave accent (\\=`) by a left quote, and each
3900 right single quotation mark (\\=’) and apostrophe (\\=') by a right quote.
3901 The left and right quote replacement characters are specified by
3902 `text-quoting-style'.
3904 usage: (format-message STRING &rest OBJECTS) */)
3905 (ptrdiff_t nargs, Lisp_Object *args)
3907 return styled_format (nargs, args, true);
3910 /* Implement ‘format-message’ if MESSAGE is true, ‘format’ otherwise. */
3912 static Lisp_Object
3913 styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message)
3915 ptrdiff_t n; /* The number of the next arg to substitute. */
3916 char initial_buffer[4000];
3917 char *buf = initial_buffer;
3918 ptrdiff_t bufsize = sizeof initial_buffer;
3919 ptrdiff_t max_bufsize = STRING_BYTES_BOUND + 1;
3920 char *p;
3921 ptrdiff_t buf_save_value_index IF_LINT (= 0);
3922 char *format, *end;
3923 ptrdiff_t nchars;
3924 /* When we make a multibyte string, we must pay attention to the
3925 byte combining problem, i.e., a byte may be combined with a
3926 multibyte character of the previous string. This flag tells if we
3927 must consider such a situation or not. */
3928 bool maybe_combine_byte;
3929 bool arg_intervals = false;
3930 USE_SAFE_ALLOCA;
3932 /* Each element records, for one argument,
3933 the start and end bytepos in the output string,
3934 whether the argument has been converted to string (e.g., due to "%S"),
3935 and whether the argument is a string with intervals. */
3936 struct info
3938 ptrdiff_t start, end;
3939 bool_bf converted_to_string : 1;
3940 bool_bf intervals : 1;
3941 } *info;
3943 CHECK_STRING (args[0]);
3944 char *format_start = SSDATA (args[0]);
3945 ptrdiff_t formatlen = SBYTES (args[0]);
3947 /* Allocate the info and discarded tables. */
3948 ptrdiff_t alloca_size;
3949 if (INT_MULTIPLY_WRAPV (nargs, sizeof *info, &alloca_size)
3950 || INT_ADD_WRAPV (sizeof *info, alloca_size, &alloca_size)
3951 || INT_ADD_WRAPV (formatlen, alloca_size, &alloca_size)
3952 || SIZE_MAX < alloca_size)
3953 memory_full (SIZE_MAX);
3954 /* info[0] is unused. Unused elements have -1 for start. */
3955 info = SAFE_ALLOCA (alloca_size);
3956 memset (info, 0, alloca_size);
3957 for (ptrdiff_t i = 0; i < nargs + 1; i++)
3958 info[i].start = -1;
3959 /* discarded[I] is 1 if byte I of the format
3960 string was not copied into the output.
3961 It is 2 if byte I was not the first byte of its character. */
3962 char *discarded = (char *) &info[nargs + 1];
3964 /* Try to determine whether the result should be multibyte.
3965 This is not always right; sometimes the result needs to be multibyte
3966 because of an object that we will pass through prin1.
3967 or because a grave accent or apostrophe is requoted,
3968 and in that case, we won't know it here. */
3970 /* True if the format is multibyte. */
3971 bool multibyte_format = STRING_MULTIBYTE (args[0]);
3972 /* True if the output should be a multibyte string,
3973 which is true if any of the inputs is one. */
3974 bool multibyte = multibyte_format;
3975 for (ptrdiff_t i = 1; !multibyte && i < nargs; i++)
3976 if (STRINGP (args[i]) && STRING_MULTIBYTE (args[i]))
3977 multibyte = true;
3979 int quoting_style = message ? text_quoting_style () : -1;
3981 /* If we start out planning a unibyte result,
3982 then discover it has to be multibyte, we jump back to retry. */
3983 retry:
3985 p = buf;
3986 nchars = 0;
3987 n = 0;
3989 /* Scan the format and store result in BUF. */
3990 format = format_start;
3991 end = format + formatlen;
3992 maybe_combine_byte = false;
3994 while (format != end)
3996 /* The values of N and FORMAT when the loop body is entered. */
3997 ptrdiff_t n0 = n;
3998 char *format0 = format;
3999 char const *convsrc = format;
4000 unsigned char format_char = *format++;
4002 /* Bytes needed to represent the output of this conversion. */
4003 ptrdiff_t convbytes = 1;
4005 if (format_char == '%')
4007 /* General format specifications look like
4009 '%' [flags] [field-width] [precision] format
4011 where
4013 flags ::= [-+0# ]+
4014 field-width ::= [0-9]+
4015 precision ::= '.' [0-9]*
4017 If a field-width is specified, it specifies to which width
4018 the output should be padded with blanks, if the output
4019 string is shorter than field-width.
4021 If precision is specified, it specifies the number of
4022 digits to print after the '.' for floats, or the max.
4023 number of chars to print from a string. */
4025 bool minus_flag = false;
4026 bool plus_flag = false;
4027 bool space_flag = false;
4028 bool sharp_flag = false;
4029 bool zero_flag = false;
4031 for (; ; format++)
4033 switch (*format)
4035 case '-': minus_flag = true; continue;
4036 case '+': plus_flag = true; continue;
4037 case ' ': space_flag = true; continue;
4038 case '#': sharp_flag = true; continue;
4039 case '0': zero_flag = true; continue;
4041 break;
4044 /* Ignore flags when sprintf ignores them. */
4045 space_flag &= ~ plus_flag;
4046 zero_flag &= ~ minus_flag;
4048 char *num_end;
4049 uintmax_t raw_field_width = strtoumax (format, &num_end, 10);
4050 if (max_bufsize <= raw_field_width)
4051 string_overflow ();
4052 ptrdiff_t field_width = raw_field_width;
4054 bool precision_given = *num_end == '.';
4055 uintmax_t precision = (precision_given
4056 ? strtoumax (num_end + 1, &num_end, 10)
4057 : UINTMAX_MAX);
4058 format = num_end;
4060 if (format == end)
4061 error ("Format string ends in middle of format specifier");
4063 char conversion = *format++;
4064 memset (&discarded[format0 - format_start], 1,
4065 format - format0 - (conversion == '%'));
4066 if (conversion == '%')
4067 goto copy_char;
4069 ++n;
4070 if (! (n < nargs))
4071 error ("Not enough arguments for format string");
4073 /* For 'S', prin1 the argument, and then treat like 's'.
4074 For 's', princ any argument that is not a string or
4075 symbol. But don't do this conversion twice, which might
4076 happen after retrying. */
4077 if ((conversion == 'S'
4078 || (conversion == 's'
4079 && ! STRINGP (args[n]) && ! SYMBOLP (args[n]))))
4081 if (! info[n].converted_to_string)
4083 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
4084 args[n] = Fprin1_to_string (args[n], noescape);
4085 info[n].converted_to_string = true;
4086 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
4088 multibyte = true;
4089 goto retry;
4092 conversion = 's';
4094 else if (conversion == 'c')
4096 if (FLOATP (args[n]))
4098 double d = XFLOAT_DATA (args[n]);
4099 args[n] = make_number (FIXNUM_OVERFLOW_P (d) ? -1 : d);
4102 if (INTEGERP (args[n]) && ! ASCII_CHAR_P (XINT (args[n])))
4104 if (!multibyte)
4106 multibyte = true;
4107 goto retry;
4109 args[n] = Fchar_to_string (args[n]);
4110 info[n].converted_to_string = true;
4113 if (info[n].converted_to_string)
4114 conversion = 's';
4115 zero_flag = false;
4118 if (SYMBOLP (args[n]))
4120 args[n] = SYMBOL_NAME (args[n]);
4121 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
4123 multibyte = true;
4124 goto retry;
4128 if (conversion == 's')
4130 /* handle case (precision[n] >= 0) */
4132 ptrdiff_t prec = -1;
4133 if (precision_given && precision <= TYPE_MAXIMUM (ptrdiff_t))
4134 prec = precision;
4136 /* lisp_string_width ignores a precision of 0, but GNU
4137 libc functions print 0 characters when the precision
4138 is 0. Imitate libc behavior here. Changing
4139 lisp_string_width is the right thing, and will be
4140 done, but meanwhile we work with it. */
4142 ptrdiff_t width, nbytes;
4143 ptrdiff_t nchars_string;
4144 if (prec == 0)
4145 width = nchars_string = nbytes = 0;
4146 else
4148 ptrdiff_t nch, nby;
4149 width = lisp_string_width (args[n], prec, &nch, &nby);
4150 if (prec < 0)
4152 nchars_string = SCHARS (args[n]);
4153 nbytes = SBYTES (args[n]);
4155 else
4157 nchars_string = nch;
4158 nbytes = nby;
4162 convbytes = nbytes;
4163 if (convbytes && multibyte && ! STRING_MULTIBYTE (args[n]))
4164 convbytes = count_size_as_multibyte (SDATA (args[n]), nbytes);
4166 ptrdiff_t padding
4167 = width < field_width ? field_width - width : 0;
4169 if (max_bufsize - padding <= convbytes)
4170 string_overflow ();
4171 convbytes += padding;
4172 if (convbytes <= buf + bufsize - p)
4174 if (! minus_flag)
4176 memset (p, ' ', padding);
4177 p += padding;
4178 nchars += padding;
4181 if (p > buf
4182 && multibyte
4183 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
4184 && STRING_MULTIBYTE (args[n])
4185 && !CHAR_HEAD_P (SREF (args[n], 0)))
4186 maybe_combine_byte = true;
4188 p += copy_text (SDATA (args[n]), (unsigned char *) p,
4189 nbytes,
4190 STRING_MULTIBYTE (args[n]), multibyte);
4192 info[n].start = nchars;
4193 nchars += nchars_string;
4194 info[n].end = nchars;
4196 if (minus_flag)
4198 memset (p, ' ', padding);
4199 p += padding;
4200 nchars += padding;
4203 /* If this argument has text properties, record where
4204 in the result string it appears. */
4205 if (string_intervals (args[n]))
4206 info[n].intervals = arg_intervals = true;
4208 continue;
4211 else if (! (conversion == 'c' || conversion == 'd'
4212 || conversion == 'e' || conversion == 'f'
4213 || conversion == 'g' || conversion == 'i'
4214 || conversion == 'o' || conversion == 'x'
4215 || conversion == 'X'))
4216 error ("Invalid format operation %%%c",
4217 STRING_CHAR ((unsigned char *) format - 1));
4218 else if (! NUMBERP (args[n]))
4219 error ("Format specifier doesn't match argument type");
4220 else
4222 enum
4224 /* Maximum precision for a %f conversion such that the
4225 trailing output digit might be nonzero. Any precision
4226 larger than this will not yield useful information. */
4227 USEFUL_PRECISION_MAX =
4228 ((1 - DBL_MIN_EXP)
4229 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
4230 : FLT_RADIX == 16 ? 4
4231 : -1)),
4233 /* Maximum number of bytes generated by any format, if
4234 precision is no more than USEFUL_PRECISION_MAX.
4235 On all practical hosts, %f is the worst case. */
4236 SPRINTF_BUFSIZE =
4237 sizeof "-." + (DBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX,
4239 /* Length of pM (that is, of pMd without the
4240 trailing "d"). */
4241 pMlen = sizeof pMd - 2
4243 verify (USEFUL_PRECISION_MAX > 0);
4245 /* Avoid undefined behavior in underlying sprintf. */
4246 if (conversion == 'd' || conversion == 'i')
4247 sharp_flag = false;
4249 /* Create the copy of the conversion specification, with
4250 any width and precision removed, with ".*" inserted,
4251 and with pM inserted for integer formats.
4252 At most three flags F can be specified at once. */
4253 char convspec[sizeof "%FFF.*d" + pMlen];
4255 char *f = convspec;
4256 *f++ = '%';
4257 *f = '-'; f += minus_flag;
4258 *f = '+'; f += plus_flag;
4259 *f = ' '; f += space_flag;
4260 *f = '#'; f += sharp_flag;
4261 *f = '0'; f += zero_flag;
4262 *f++ = '.';
4263 *f++ = '*';
4264 if (conversion == 'd' || conversion == 'i'
4265 || conversion == 'o' || conversion == 'x'
4266 || conversion == 'X')
4268 memcpy (f, pMd, pMlen);
4269 f += pMlen;
4270 zero_flag &= ~ precision_given;
4272 *f++ = conversion;
4273 *f = '\0';
4276 int prec = -1;
4277 if (precision_given)
4278 prec = min (precision, USEFUL_PRECISION_MAX);
4280 /* Use sprintf to format this number into sprintf_buf. Omit
4281 padding and excess precision, though, because sprintf limits
4282 output length to INT_MAX.
4284 There are four types of conversion: double, unsigned
4285 char (passed as int), wide signed int, and wide
4286 unsigned int. Treat them separately because the
4287 sprintf ABI is sensitive to which type is passed. Be
4288 careful about integer overflow, NaNs, infinities, and
4289 conversions; for example, the min and max macros are
4290 not suitable here. */
4291 char sprintf_buf[SPRINTF_BUFSIZE];
4292 ptrdiff_t sprintf_bytes;
4293 if (conversion == 'e' || conversion == 'f' || conversion == 'g')
4295 double x = (INTEGERP (args[n])
4296 ? XINT (args[n])
4297 : XFLOAT_DATA (args[n]));
4298 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4300 else if (conversion == 'c')
4302 /* Don't use sprintf here, as it might mishandle prec. */
4303 sprintf_buf[0] = XINT (args[n]);
4304 sprintf_bytes = prec != 0;
4306 else if (conversion == 'd')
4308 /* For float, maybe we should use "%1.0f"
4309 instead so it also works for values outside
4310 the integer range. */
4311 printmax_t x;
4312 if (INTEGERP (args[n]))
4313 x = XINT (args[n]);
4314 else
4316 double d = XFLOAT_DATA (args[n]);
4317 if (d < 0)
4319 x = TYPE_MINIMUM (printmax_t);
4320 if (x < d)
4321 x = d;
4323 else
4325 x = TYPE_MAXIMUM (printmax_t);
4326 if (d < x)
4327 x = d;
4330 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4332 else
4334 /* Don't sign-extend for octal or hex printing. */
4335 uprintmax_t x;
4336 if (INTEGERP (args[n]))
4337 x = XUINT (args[n]);
4338 else
4340 double d = XFLOAT_DATA (args[n]);
4341 if (d < 0)
4342 x = 0;
4343 else
4345 x = TYPE_MAXIMUM (uprintmax_t);
4346 if (d < x)
4347 x = d;
4350 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4353 /* Now the length of the formatted item is known, except it omits
4354 padding and excess precision. Deal with excess precision
4355 first. This happens only when the format specifies
4356 ridiculously large precision. */
4357 uintmax_t excess_precision = precision - prec;
4358 uintmax_t leading_zeros = 0, trailing_zeros = 0;
4359 if (excess_precision)
4361 if (conversion == 'e' || conversion == 'f'
4362 || conversion == 'g')
4364 if ((conversion == 'g' && ! sharp_flag)
4365 || ! ('0' <= sprintf_buf[sprintf_bytes - 1]
4366 && sprintf_buf[sprintf_bytes - 1] <= '9'))
4367 excess_precision = 0;
4368 else
4370 if (conversion == 'g')
4372 char *dot = strchr (sprintf_buf, '.');
4373 if (!dot)
4374 excess_precision = 0;
4377 trailing_zeros = excess_precision;
4379 else
4380 leading_zeros = excess_precision;
4383 /* Compute the total bytes needed for this item, including
4384 excess precision and padding. */
4385 uintmax_t numwidth = sprintf_bytes + excess_precision;
4386 ptrdiff_t padding
4387 = numwidth < field_width ? field_width - numwidth : 0;
4388 if (max_bufsize - sprintf_bytes <= excess_precision
4389 || max_bufsize - padding <= numwidth)
4390 string_overflow ();
4391 convbytes = numwidth + padding;
4393 if (convbytes <= buf + bufsize - p)
4395 /* Copy the formatted item from sprintf_buf into buf,
4396 inserting padding and excess-precision zeros. */
4398 char *src = sprintf_buf;
4399 char src0 = src[0];
4400 int exponent_bytes = 0;
4401 bool signedp = src0 == '-' || src0 == '+' || src0 == ' ';
4402 if (zero_flag
4403 && ((src[signedp] >= '0' && src[signedp] <= '9')
4404 || (src[signedp] >= 'a' && src[signedp] <= 'f')
4405 || (src[signedp] >= 'A' && src[signedp] <= 'F')))
4407 leading_zeros += padding;
4408 padding = 0;
4411 if (excess_precision
4412 && (conversion == 'e' || conversion == 'g'))
4414 char *e = strchr (src, 'e');
4415 if (e)
4416 exponent_bytes = src + sprintf_bytes - e;
4419 if (! minus_flag)
4421 memset (p, ' ', padding);
4422 p += padding;
4423 nchars += padding;
4426 *p = src0;
4427 src += signedp;
4428 p += signedp;
4429 memset (p, '0', leading_zeros);
4430 p += leading_zeros;
4431 int significand_bytes
4432 = sprintf_bytes - signedp - exponent_bytes;
4433 memcpy (p, src, significand_bytes);
4434 p += significand_bytes;
4435 src += significand_bytes;
4436 memset (p, '0', trailing_zeros);
4437 p += trailing_zeros;
4438 memcpy (p, src, exponent_bytes);
4439 p += exponent_bytes;
4441 info[n].start = nchars;
4442 nchars += leading_zeros + sprintf_bytes + trailing_zeros;
4443 info[n].end = nchars;
4445 if (minus_flag)
4447 memset (p, ' ', padding);
4448 p += padding;
4449 nchars += padding;
4452 continue;
4456 else
4458 unsigned char str[MAX_MULTIBYTE_LENGTH];
4460 if ((format_char == '`' || format_char == '\'')
4461 && quoting_style == CURVE_QUOTING_STYLE)
4463 if (! multibyte)
4465 multibyte = true;
4466 goto retry;
4468 convsrc = format_char == '`' ? uLSQM : uRSQM;
4469 convbytes = 3;
4471 else if (format_char == '`' && quoting_style == STRAIGHT_QUOTING_STYLE)
4472 convsrc = "'";
4473 else
4475 /* Copy a single character from format to buf. */
4476 if (multibyte_format)
4478 /* Copy a whole multibyte character. */
4479 if (p > buf
4480 && !ASCII_CHAR_P (*((unsigned char *) p - 1))
4481 && !CHAR_HEAD_P (format_char))
4482 maybe_combine_byte = true;
4484 while (! CHAR_HEAD_P (*format))
4485 format++;
4487 convbytes = format - format0;
4488 memset (&discarded[format0 + 1 - format_start], 2,
4489 convbytes - 1);
4491 else if (multibyte && !ASCII_CHAR_P (format_char))
4493 int c = BYTE8_TO_CHAR (format_char);
4494 convbytes = CHAR_STRING (c, str);
4495 convsrc = (char *) str;
4499 copy_char:
4500 if (convbytes <= buf + bufsize - p)
4502 memcpy (p, convsrc, convbytes);
4503 p += convbytes;
4504 nchars++;
4505 continue;
4509 /* There wasn't enough room to store this conversion or single
4510 character. CONVBYTES says how much room is needed. Allocate
4511 enough room (and then some) and do it again. */
4513 ptrdiff_t used = p - buf;
4514 if (max_bufsize - used < convbytes)
4515 string_overflow ();
4516 bufsize = used + convbytes;
4517 bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize;
4519 if (buf == initial_buffer)
4521 buf = xmalloc (bufsize);
4522 sa_must_free = true;
4523 buf_save_value_index = SPECPDL_INDEX ();
4524 record_unwind_protect_ptr (xfree, buf);
4525 memcpy (buf, initial_buffer, used);
4527 else
4529 buf = xrealloc (buf, bufsize);
4530 set_unwind_protect_ptr (buf_save_value_index, xfree, buf);
4533 p = buf + used;
4534 format = format0;
4535 n = n0;
4538 if (bufsize < p - buf)
4539 emacs_abort ();
4541 if (maybe_combine_byte)
4542 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf);
4543 Lisp_Object val = make_specified_string (buf, nchars, p - buf, multibyte);
4545 /* If the format string has text properties, or any of the string
4546 arguments has text properties, set up text properties of the
4547 result string. */
4549 if (string_intervals (args[0]) || arg_intervals)
4551 /* Add text properties from the format string. */
4552 Lisp_Object len = make_number (SCHARS (args[0]));
4553 Lisp_Object props = text_property_list (args[0], make_number (0),
4554 len, Qnil);
4555 if (CONSP (props))
4557 ptrdiff_t bytepos = 0, position = 0, translated = 0;
4558 ptrdiff_t argn = 1;
4560 /* Adjust the bounds of each text property
4561 to the proper start and end in the output string. */
4563 /* Put the positions in PROPS in increasing order, so that
4564 we can do (effectively) one scan through the position
4565 space of the format string. */
4566 props = Fnreverse (props);
4568 /* BYTEPOS is the byte position in the format string,
4569 POSITION is the untranslated char position in it,
4570 TRANSLATED is the translated char position in BUF,
4571 and ARGN is the number of the next arg we will come to. */
4572 for (Lisp_Object list = props; CONSP (list); list = XCDR (list))
4574 Lisp_Object item = XCAR (list);
4576 /* First adjust the property start position. */
4577 ptrdiff_t pos = XINT (XCAR (item));
4579 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4580 up to this position. */
4581 for (; position < pos; bytepos++)
4583 if (! discarded[bytepos])
4584 position++, translated++;
4585 else if (discarded[bytepos] == 1)
4587 position++;
4588 if (translated == info[argn].start)
4590 translated += info[argn].end - info[argn].start;
4591 argn++;
4596 XSETCAR (item, make_number (translated));
4598 /* Likewise adjust the property end position. */
4599 pos = XINT (XCAR (XCDR (item)));
4601 for (; position < pos; bytepos++)
4603 if (! discarded[bytepos])
4604 position++, translated++;
4605 else if (discarded[bytepos] == 1)
4607 position++;
4608 if (translated == info[argn].start)
4610 translated += info[argn].end - info[argn].start;
4611 argn++;
4616 XSETCAR (XCDR (item), make_number (translated));
4619 add_text_properties_from_list (val, props, make_number (0));
4622 /* Add text properties from arguments. */
4623 if (arg_intervals)
4624 for (ptrdiff_t i = 1; i < nargs; i++)
4625 if (info[i].intervals)
4627 len = make_number (SCHARS (args[i]));
4628 Lisp_Object new_len = make_number (info[i].end - info[i].start);
4629 props = text_property_list (args[i], make_number (0), len, Qnil);
4630 props = extend_property_ranges (props, new_len);
4631 /* If successive arguments have properties, be sure that
4632 the value of `composition' property be the copy. */
4633 if (1 < i && info[i - 1].end)
4634 make_composition_value_copy (props);
4635 add_text_properties_from_list (val, props,
4636 make_number (info[i].start));
4640 /* If we allocated BUF or INFO with malloc, free it too. */
4641 SAFE_FREE ();
4643 return val;
4646 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
4647 doc: /* Return t if two characters match, optionally ignoring case.
4648 Both arguments must be characters (i.e. integers).
4649 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4650 (register Lisp_Object c1, Lisp_Object c2)
4652 int i1, i2;
4653 /* Check they're chars, not just integers, otherwise we could get array
4654 bounds violations in downcase. */
4655 CHECK_CHARACTER (c1);
4656 CHECK_CHARACTER (c2);
4658 if (XINT (c1) == XINT (c2))
4659 return Qt;
4660 if (NILP (BVAR (current_buffer, case_fold_search)))
4661 return Qnil;
4663 i1 = XFASTINT (c1);
4664 i2 = XFASTINT (c2);
4666 /* FIXME: It is possible to compare multibyte characters even when
4667 the current buffer is unibyte. Unfortunately this is ambiguous
4668 for characters between 128 and 255, as they could be either
4669 eight-bit raw bytes or Latin-1 characters. Assume the former for
4670 now. See Bug#17011, and also see casefiddle.c's casify_object,
4671 which has a similar problem. */
4672 if (NILP (BVAR (current_buffer, enable_multibyte_characters)))
4674 if (SINGLE_BYTE_CHAR_P (i1))
4675 i1 = UNIBYTE_TO_CHAR (i1);
4676 if (SINGLE_BYTE_CHAR_P (i2))
4677 i2 = UNIBYTE_TO_CHAR (i2);
4680 return (downcase (i1) == downcase (i2) ? Qt : Qnil);
4683 /* Transpose the markers in two regions of the current buffer, and
4684 adjust the ones between them if necessary (i.e.: if the regions
4685 differ in size).
4687 START1, END1 are the character positions of the first region.
4688 START1_BYTE, END1_BYTE are the byte positions.
4689 START2, END2 are the character positions of the second region.
4690 START2_BYTE, END2_BYTE are the byte positions.
4692 Traverses the entire marker list of the buffer to do so, adding an
4693 appropriate amount to some, subtracting from some, and leaving the
4694 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4696 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4698 static void
4699 transpose_markers (ptrdiff_t start1, ptrdiff_t end1,
4700 ptrdiff_t start2, ptrdiff_t end2,
4701 ptrdiff_t start1_byte, ptrdiff_t end1_byte,
4702 ptrdiff_t start2_byte, ptrdiff_t end2_byte)
4704 register ptrdiff_t amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
4705 register struct Lisp_Marker *marker;
4707 /* Update point as if it were a marker. */
4708 if (PT < start1)
4710 else if (PT < end1)
4711 TEMP_SET_PT_BOTH (PT + (end2 - end1),
4712 PT_BYTE + (end2_byte - end1_byte));
4713 else if (PT < start2)
4714 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
4715 (PT_BYTE + (end2_byte - start2_byte)
4716 - (end1_byte - start1_byte)));
4717 else if (PT < end2)
4718 TEMP_SET_PT_BOTH (PT - (start2 - start1),
4719 PT_BYTE - (start2_byte - start1_byte));
4721 /* We used to adjust the endpoints here to account for the gap, but that
4722 isn't good enough. Even if we assume the caller has tried to move the
4723 gap out of our way, it might still be at start1 exactly, for example;
4724 and that places it `inside' the interval, for our purposes. The amount
4725 of adjustment is nontrivial if there's a `denormalized' marker whose
4726 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4727 the dirty work to Fmarker_position, below. */
4729 /* The difference between the region's lengths */
4730 diff = (end2 - start2) - (end1 - start1);
4731 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
4733 /* For shifting each marker in a region by the length of the other
4734 region plus the distance between the regions. */
4735 amt1 = (end2 - start2) + (start2 - end1);
4736 amt2 = (end1 - start1) + (start2 - end1);
4737 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
4738 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
4740 for (marker = BUF_MARKERS (current_buffer); marker; marker = marker->next)
4742 mpos = marker->bytepos;
4743 if (mpos >= start1_byte && mpos < end2_byte)
4745 if (mpos < end1_byte)
4746 mpos += amt1_byte;
4747 else if (mpos < start2_byte)
4748 mpos += diff_byte;
4749 else
4750 mpos -= amt2_byte;
4751 marker->bytepos = mpos;
4753 mpos = marker->charpos;
4754 if (mpos >= start1 && mpos < end2)
4756 if (mpos < end1)
4757 mpos += amt1;
4758 else if (mpos < start2)
4759 mpos += diff;
4760 else
4761 mpos -= amt2;
4763 marker->charpos = mpos;
4767 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
4768 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4769 The regions should not be overlapping, because the size of the buffer is
4770 never changed in a transposition.
4772 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4773 any markers that happen to be located in the regions.
4775 Transposing beyond buffer boundaries is an error. */)
4776 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
4778 register ptrdiff_t start1, end1, start2, end2;
4779 ptrdiff_t start1_byte, start2_byte, len1_byte, len2_byte, end2_byte;
4780 ptrdiff_t gap, len1, len_mid, len2;
4781 unsigned char *start1_addr, *start2_addr, *temp;
4783 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2, tmp_interval3;
4784 Lisp_Object buf;
4786 XSETBUFFER (buf, current_buffer);
4787 cur_intv = buffer_intervals (current_buffer);
4789 validate_region (&startr1, &endr1);
4790 validate_region (&startr2, &endr2);
4792 start1 = XFASTINT (startr1);
4793 end1 = XFASTINT (endr1);
4794 start2 = XFASTINT (startr2);
4795 end2 = XFASTINT (endr2);
4796 gap = GPT;
4798 /* Swap the regions if they're reversed. */
4799 if (start2 < end1)
4801 register ptrdiff_t glumph = start1;
4802 start1 = start2;
4803 start2 = glumph;
4804 glumph = end1;
4805 end1 = end2;
4806 end2 = glumph;
4809 len1 = end1 - start1;
4810 len2 = end2 - start2;
4812 if (start2 < end1)
4813 error ("Transposed regions overlap");
4814 /* Nothing to change for adjacent regions with one being empty */
4815 else if ((start1 == end1 || start2 == end2) && end1 == start2)
4816 return Qnil;
4818 /* The possibilities are:
4819 1. Adjacent (contiguous) regions, or separate but equal regions
4820 (no, really equal, in this case!), or
4821 2. Separate regions of unequal size.
4823 The worst case is usually No. 2. It means that (aside from
4824 potential need for getting the gap out of the way), there also
4825 needs to be a shifting of the text between the two regions. So
4826 if they are spread far apart, we are that much slower... sigh. */
4828 /* It must be pointed out that the really studly thing to do would
4829 be not to move the gap at all, but to leave it in place and work
4830 around it if necessary. This would be extremely efficient,
4831 especially considering that people are likely to do
4832 transpositions near where they are working interactively, which
4833 is exactly where the gap would be found. However, such code
4834 would be much harder to write and to read. So, if you are
4835 reading this comment and are feeling squirrely, by all means have
4836 a go! I just didn't feel like doing it, so I will simply move
4837 the gap the minimum distance to get it out of the way, and then
4838 deal with an unbroken array. */
4840 start1_byte = CHAR_TO_BYTE (start1);
4841 end2_byte = CHAR_TO_BYTE (end2);
4843 /* Make sure the gap won't interfere, by moving it out of the text
4844 we will operate on. */
4845 if (start1 < gap && gap < end2)
4847 if (gap - start1 < end2 - gap)
4848 move_gap_both (start1, start1_byte);
4849 else
4850 move_gap_both (end2, end2_byte);
4853 start2_byte = CHAR_TO_BYTE (start2);
4854 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
4855 len2_byte = end2_byte - start2_byte;
4857 #ifdef BYTE_COMBINING_DEBUG
4858 if (end1 == start2)
4860 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4861 len2_byte, start1, start1_byte)
4862 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4863 len1_byte, end2, start2_byte + len2_byte)
4864 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4865 len1_byte, end2, start2_byte + len2_byte))
4866 emacs_abort ();
4868 else
4870 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4871 len2_byte, start1, start1_byte)
4872 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4873 len1_byte, start2, start2_byte)
4874 || count_combining_after (BYTE_POS_ADDR (start2_byte),
4875 len2_byte, end1, start1_byte + len1_byte)
4876 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4877 len1_byte, end2, start2_byte + len2_byte))
4878 emacs_abort ();
4880 #endif
4882 /* Hmmm... how about checking to see if the gap is large
4883 enough to use as the temporary storage? That would avoid an
4884 allocation... interesting. Later, don't fool with it now. */
4886 /* Working without memmove, for portability (sigh), so must be
4887 careful of overlapping subsections of the array... */
4889 if (end1 == start2) /* adjacent regions */
4891 modify_text (start1, end2);
4892 record_change (start1, len1 + len2);
4894 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4895 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4896 /* Don't use Fset_text_properties: that can cause GC, which can
4897 clobber objects stored in the tmp_intervals. */
4898 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4899 if (tmp_interval3)
4900 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4902 USE_SAFE_ALLOCA;
4904 /* First region smaller than second. */
4905 if (len1_byte < len2_byte)
4907 temp = SAFE_ALLOCA (len2_byte);
4909 /* Don't precompute these addresses. We have to compute them
4910 at the last minute, because the relocating allocator might
4911 have moved the buffer around during the xmalloc. */
4912 start1_addr = BYTE_POS_ADDR (start1_byte);
4913 start2_addr = BYTE_POS_ADDR (start2_byte);
4915 memcpy (temp, start2_addr, len2_byte);
4916 memcpy (start1_addr + len2_byte, start1_addr, len1_byte);
4917 memcpy (start1_addr, temp, len2_byte);
4919 else
4920 /* First region not smaller than second. */
4922 temp = SAFE_ALLOCA (len1_byte);
4923 start1_addr = BYTE_POS_ADDR (start1_byte);
4924 start2_addr = BYTE_POS_ADDR (start2_byte);
4925 memcpy (temp, start1_addr, len1_byte);
4926 memcpy (start1_addr, start2_addr, len2_byte);
4927 memcpy (start1_addr + len2_byte, temp, len1_byte);
4930 SAFE_FREE ();
4931 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
4932 len1, current_buffer, 0);
4933 graft_intervals_into_buffer (tmp_interval2, start1,
4934 len2, current_buffer, 0);
4935 update_compositions (start1, start1 + len2, CHECK_BORDER);
4936 update_compositions (start1 + len2, end2, CHECK_TAIL);
4938 /* Non-adjacent regions, because end1 != start2, bleagh... */
4939 else
4941 len_mid = start2_byte - (start1_byte + len1_byte);
4943 if (len1_byte == len2_byte)
4944 /* Regions are same size, though, how nice. */
4946 USE_SAFE_ALLOCA;
4948 modify_text (start1, end1);
4949 modify_text (start2, end2);
4950 record_change (start1, len1);
4951 record_change (start2, len2);
4952 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4953 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4955 tmp_interval3 = validate_interval_range (buf, &startr1, &endr1, 0);
4956 if (tmp_interval3)
4957 set_text_properties_1 (startr1, endr1, Qnil, buf, tmp_interval3);
4959 tmp_interval3 = validate_interval_range (buf, &startr2, &endr2, 0);
4960 if (tmp_interval3)
4961 set_text_properties_1 (startr2, endr2, Qnil, buf, tmp_interval3);
4963 temp = SAFE_ALLOCA (len1_byte);
4964 start1_addr = BYTE_POS_ADDR (start1_byte);
4965 start2_addr = BYTE_POS_ADDR (start2_byte);
4966 memcpy (temp, start1_addr, len1_byte);
4967 memcpy (start1_addr, start2_addr, len2_byte);
4968 memcpy (start2_addr, temp, len1_byte);
4969 SAFE_FREE ();
4971 graft_intervals_into_buffer (tmp_interval1, start2,
4972 len1, current_buffer, 0);
4973 graft_intervals_into_buffer (tmp_interval2, start1,
4974 len2, current_buffer, 0);
4977 else if (len1_byte < len2_byte) /* Second region larger than first */
4978 /* Non-adjacent & unequal size, area between must also be shifted. */
4980 USE_SAFE_ALLOCA;
4982 modify_text (start1, end2);
4983 record_change (start1, (end2 - start1));
4984 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4985 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4986 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4988 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4989 if (tmp_interval3)
4990 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4992 /* holds region 2 */
4993 temp = SAFE_ALLOCA (len2_byte);
4994 start1_addr = BYTE_POS_ADDR (start1_byte);
4995 start2_addr = BYTE_POS_ADDR (start2_byte);
4996 memcpy (temp, start2_addr, len2_byte);
4997 memcpy (start1_addr + len_mid + len2_byte, start1_addr, len1_byte);
4998 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4999 memcpy (start1_addr, temp, len2_byte);
5000 SAFE_FREE ();
5002 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
5003 len1, current_buffer, 0);
5004 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
5005 len_mid, current_buffer, 0);
5006 graft_intervals_into_buffer (tmp_interval2, start1,
5007 len2, current_buffer, 0);
5009 else
5010 /* Second region smaller than first. */
5012 USE_SAFE_ALLOCA;
5014 record_change (start1, (end2 - start1));
5015 modify_text (start1, end2);
5017 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
5018 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
5019 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
5021 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
5022 if (tmp_interval3)
5023 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
5025 /* holds region 1 */
5026 temp = SAFE_ALLOCA (len1_byte);
5027 start1_addr = BYTE_POS_ADDR (start1_byte);
5028 start2_addr = BYTE_POS_ADDR (start2_byte);
5029 memcpy (temp, start1_addr, len1_byte);
5030 memcpy (start1_addr, start2_addr, len2_byte);
5031 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
5032 memcpy (start1_addr + len2_byte + len_mid, temp, len1_byte);
5033 SAFE_FREE ();
5035 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
5036 len1, current_buffer, 0);
5037 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
5038 len_mid, current_buffer, 0);
5039 graft_intervals_into_buffer (tmp_interval2, start1,
5040 len2, current_buffer, 0);
5043 update_compositions (start1, start1 + len2, CHECK_BORDER);
5044 update_compositions (end2 - len1, end2, CHECK_BORDER);
5047 /* When doing multiple transpositions, it might be nice
5048 to optimize this. Perhaps the markers in any one buffer
5049 should be organized in some sorted data tree. */
5050 if (NILP (leave_markers))
5052 transpose_markers (start1, end1, start2, end2,
5053 start1_byte, start1_byte + len1_byte,
5054 start2_byte, start2_byte + len2_byte);
5055 fix_start_end_in_overlays (start1, end2);
5058 signal_after_change (start1, end2 - start1, end2 - start1);
5059 return Qnil;
5063 void
5064 syms_of_editfns (void)
5066 DEFSYM (Qbuffer_access_fontify_functions, "buffer-access-fontify-functions");
5067 DEFSYM (Qwall, "wall");
5069 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
5070 doc: /* Non-nil means text motion commands don't notice fields. */);
5071 Vinhibit_field_text_motion = Qnil;
5073 DEFVAR_LISP ("buffer-access-fontify-functions",
5074 Vbuffer_access_fontify_functions,
5075 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
5076 Each function is called with two arguments which specify the range
5077 of the buffer being accessed. */);
5078 Vbuffer_access_fontify_functions = Qnil;
5081 Lisp_Object obuf;
5082 obuf = Fcurrent_buffer ();
5083 /* Do this here, because init_buffer_once is too early--it won't work. */
5084 Fset_buffer (Vprin1_to_string_buffer);
5085 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
5086 Fset (Fmake_local_variable (Qbuffer_access_fontify_functions), Qnil);
5087 Fset_buffer (obuf);
5090 DEFVAR_LISP ("buffer-access-fontified-property",
5091 Vbuffer_access_fontified_property,
5092 doc: /* Property which (if non-nil) indicates text has been fontified.
5093 `buffer-substring' need not call the `buffer-access-fontify-functions'
5094 functions if all the text being accessed has this property. */);
5095 Vbuffer_access_fontified_property = Qnil;
5097 DEFVAR_LISP ("system-name", Vsystem_name,
5098 doc: /* The host name of the machine Emacs is running on. */);
5099 Vsystem_name = cached_system_name = Qnil;
5101 DEFVAR_LISP ("user-full-name", Vuser_full_name,
5102 doc: /* The full name of the user logged in. */);
5104 DEFVAR_LISP ("user-login-name", Vuser_login_name,
5105 doc: /* The user's name, taken from environment variables if possible. */);
5106 Vuser_login_name = Qnil;
5108 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name,
5109 doc: /* The user's name, based upon the real uid only. */);
5111 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
5112 doc: /* The release of the operating system Emacs is running on. */);
5114 defsubr (&Spropertize);
5115 defsubr (&Schar_equal);
5116 defsubr (&Sgoto_char);
5117 defsubr (&Sstring_to_char);
5118 defsubr (&Schar_to_string);
5119 defsubr (&Sbyte_to_string);
5120 defsubr (&Sbuffer_substring);
5121 defsubr (&Sbuffer_substring_no_properties);
5122 defsubr (&Sbuffer_string);
5123 defsubr (&Sget_pos_property);
5125 defsubr (&Spoint_marker);
5126 defsubr (&Smark_marker);
5127 defsubr (&Spoint);
5128 defsubr (&Sregion_beginning);
5129 defsubr (&Sregion_end);
5131 /* Symbol for the text property used to mark fields. */
5132 DEFSYM (Qfield, "field");
5134 /* A special value for Qfield properties. */
5135 DEFSYM (Qboundary, "boundary");
5137 defsubr (&Sfield_beginning);
5138 defsubr (&Sfield_end);
5139 defsubr (&Sfield_string);
5140 defsubr (&Sfield_string_no_properties);
5141 defsubr (&Sdelete_field);
5142 defsubr (&Sconstrain_to_field);
5144 defsubr (&Sline_beginning_position);
5145 defsubr (&Sline_end_position);
5147 defsubr (&Ssave_excursion);
5148 defsubr (&Ssave_current_buffer);
5150 defsubr (&Sbuffer_size);
5151 defsubr (&Spoint_max);
5152 defsubr (&Spoint_min);
5153 defsubr (&Spoint_min_marker);
5154 defsubr (&Spoint_max_marker);
5155 defsubr (&Sgap_position);
5156 defsubr (&Sgap_size);
5157 defsubr (&Sposition_bytes);
5158 defsubr (&Sbyte_to_position);
5160 defsubr (&Sbobp);
5161 defsubr (&Seobp);
5162 defsubr (&Sbolp);
5163 defsubr (&Seolp);
5164 defsubr (&Sfollowing_char);
5165 defsubr (&Sprevious_char);
5166 defsubr (&Schar_after);
5167 defsubr (&Schar_before);
5168 defsubr (&Sinsert);
5169 defsubr (&Sinsert_before_markers);
5170 defsubr (&Sinsert_and_inherit);
5171 defsubr (&Sinsert_and_inherit_before_markers);
5172 defsubr (&Sinsert_char);
5173 defsubr (&Sinsert_byte);
5175 defsubr (&Suser_login_name);
5176 defsubr (&Suser_real_login_name);
5177 defsubr (&Suser_uid);
5178 defsubr (&Suser_real_uid);
5179 defsubr (&Sgroup_gid);
5180 defsubr (&Sgroup_real_gid);
5181 defsubr (&Suser_full_name);
5182 defsubr (&Semacs_pid);
5183 defsubr (&Scurrent_time);
5184 defsubr (&Stime_add);
5185 defsubr (&Stime_subtract);
5186 defsubr (&Stime_less_p);
5187 defsubr (&Sget_internal_run_time);
5188 defsubr (&Sformat_time_string);
5189 defsubr (&Sfloat_time);
5190 defsubr (&Sdecode_time);
5191 defsubr (&Sencode_time);
5192 defsubr (&Scurrent_time_string);
5193 defsubr (&Scurrent_time_zone);
5194 defsubr (&Sset_time_zone_rule);
5195 defsubr (&Ssystem_name);
5196 defsubr (&Smessage);
5197 defsubr (&Smessage_box);
5198 defsubr (&Smessage_or_box);
5199 defsubr (&Scurrent_message);
5200 defsubr (&Sformat);
5201 defsubr (&Sformat_message);
5203 defsubr (&Sinsert_buffer_substring);
5204 defsubr (&Scompare_buffer_substrings);
5205 defsubr (&Ssubst_char_in_region);
5206 defsubr (&Stranslate_region_internal);
5207 defsubr (&Sdelete_region);
5208 defsubr (&Sdelete_and_extract_region);
5209 defsubr (&Swiden);
5210 defsubr (&Snarrow_to_region);
5211 defsubr (&Ssave_restriction);
5212 defsubr (&Stranspose_regions);