Merge from trunk.
[bpt/emacs.git] / src / editfns.c
1 /* Lisp functions pertaining to editing.
2
3 Copyright (C) 1985-1987, 1989, 1993-2011 Free Software Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
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.
16
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/>. */
19
20
21 #include <config.h>
22 #include <sys/types.h>
23 #include <stdio.h>
24 #include <setjmp.h>
25
26 #ifdef HAVE_PWD_H
27 #include <pwd.h>
28 #endif
29
30 #include <unistd.h>
31
32 #ifdef HAVE_SYS_UTSNAME_H
33 #include <sys/utsname.h>
34 #endif
35
36 #include "lisp.h"
37
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"
42
43 #if defined HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
45 #endif
46
47 #include <ctype.h>
48 #include <float.h>
49 #include <limits.h>
50 #include <intprops.h>
51 #include <strftime.h>
52 #include <verify.h>
53
54 #include "intervals.h"
55 #include "buffer.h"
56 #include "character.h"
57 #include "coding.h"
58 #include "frame.h"
59 #include "window.h"
60 #include "blockinput.h"
61
62 #ifndef NULL
63 #define NULL 0
64 #endif
65
66 #ifndef USER_FULL_NAME
67 #define USER_FULL_NAME pw->pw_gecos
68 #endif
69
70 #ifndef USE_CRT_DLL
71 extern char **environ;
72 #endif
73
74 #define TM_YEAR_BASE 1900
75
76 /* Nonzero if TM_YEAR is a struct tm's tm_year value that causes
77 asctime to have well-defined behavior. */
78 #ifndef TM_YEAR_IN_ASCTIME_RANGE
79 # define TM_YEAR_IN_ASCTIME_RANGE(tm_year) \
80 (1000 - TM_YEAR_BASE <= (tm_year) && (tm_year) <= 9999 - TM_YEAR_BASE)
81 #endif
82
83 #ifdef WINDOWSNT
84 extern Lisp_Object w32_get_internal_run_time (void);
85 #endif
86
87 static void time_overflow (void) NO_RETURN;
88 static int tm_diff (struct tm *, struct tm *);
89 static void find_field (Lisp_Object, Lisp_Object, Lisp_Object,
90 EMACS_INT *, Lisp_Object, EMACS_INT *);
91 static void update_buffer_properties (EMACS_INT, EMACS_INT);
92 static Lisp_Object region_limit (int);
93 static size_t emacs_nmemftime (char *, size_t, const char *,
94 size_t, const struct tm *, int, int);
95 static void general_insert_function (void (*) (const char *, EMACS_INT),
96 void (*) (Lisp_Object, EMACS_INT,
97 EMACS_INT, EMACS_INT,
98 EMACS_INT, int),
99 int, ptrdiff_t, Lisp_Object *);
100 static Lisp_Object subst_char_in_region_unwind (Lisp_Object);
101 static Lisp_Object subst_char_in_region_unwind_1 (Lisp_Object);
102 static void transpose_markers (EMACS_INT, EMACS_INT, EMACS_INT, EMACS_INT,
103 EMACS_INT, EMACS_INT, EMACS_INT, EMACS_INT);
104
105 static Lisp_Object Qbuffer_access_fontify_functions;
106 static Lisp_Object Fuser_full_name (Lisp_Object);
107
108 /* Symbol for the text property used to mark fields. */
109
110 Lisp_Object Qfield;
111
112 /* A special value for Qfield properties. */
113
114 static Lisp_Object Qboundary;
115
116
117 void
118 init_editfns (void)
119 {
120 const char *user_name;
121 register char *p;
122 struct passwd *pw; /* password entry for the current user */
123 Lisp_Object tem;
124
125 /* Set up system_name even when dumping. */
126 init_system_name ();
127
128 #ifndef CANNOT_DUMP
129 /* Don't bother with this on initial start when just dumping out */
130 if (!initialized)
131 return;
132 #endif /* not CANNOT_DUMP */
133
134 pw = getpwuid (getuid ());
135 #ifdef MSDOS
136 /* We let the real user name default to "root" because that's quite
137 accurate on MSDOG and because it lets Emacs find the init file.
138 (The DVX libraries override the Djgpp libraries here.) */
139 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
140 #else
141 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
142 #endif
143
144 /* Get the effective user name, by consulting environment variables,
145 or the effective uid if those are unset. */
146 user_name = getenv ("LOGNAME");
147 if (!user_name)
148 #ifdef WINDOWSNT
149 user_name = getenv ("USERNAME"); /* it's USERNAME on NT */
150 #else /* WINDOWSNT */
151 user_name = getenv ("USER");
152 #endif /* WINDOWSNT */
153 if (!user_name)
154 {
155 pw = getpwuid (geteuid ());
156 user_name = pw ? pw->pw_name : "unknown";
157 }
158 Vuser_login_name = build_string (user_name);
159
160 /* If the user name claimed in the environment vars differs from
161 the real uid, use the claimed name to find the full name. */
162 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
163 Vuser_full_name = Fuser_full_name (NILP (tem)? make_number (geteuid())
164 : Vuser_login_name);
165
166 p = getenv ("NAME");
167 if (p)
168 Vuser_full_name = build_string (p);
169 else if (NILP (Vuser_full_name))
170 Vuser_full_name = build_string ("unknown");
171
172 #ifdef HAVE_SYS_UTSNAME_H
173 {
174 struct utsname uts;
175 uname (&uts);
176 Voperating_system_release = build_string (uts.release);
177 }
178 #else
179 Voperating_system_release = Qnil;
180 #endif
181 }
182 \f
183 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
184 doc: /* Convert arg CHAR to a string containing that character.
185 usage: (char-to-string CHAR) */)
186 (Lisp_Object character)
187 {
188 int c, len;
189 unsigned char str[MAX_MULTIBYTE_LENGTH];
190
191 CHECK_CHARACTER (character);
192 c = XFASTINT (character);
193
194 len = CHAR_STRING (c, str);
195 return make_string_from_bytes ((char *) str, 1, len);
196 }
197
198 DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0,
199 doc: /* Convert arg BYTE to a unibyte string containing that byte. */)
200 (Lisp_Object byte)
201 {
202 unsigned char b;
203 CHECK_NUMBER (byte);
204 if (XINT (byte) < 0 || XINT (byte) > 255)
205 error ("Invalid byte");
206 b = XINT (byte);
207 return make_string_from_bytes ((char *) &b, 1, 1);
208 }
209
210 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
211 doc: /* Convert arg STRING to a character, the first character of that string.
212 A multibyte character is handled correctly. */)
213 (register Lisp_Object string)
214 {
215 register Lisp_Object val;
216 CHECK_STRING (string);
217 if (SCHARS (string))
218 {
219 if (STRING_MULTIBYTE (string))
220 XSETFASTINT (val, STRING_CHAR (SDATA (string)));
221 else
222 XSETFASTINT (val, SREF (string, 0));
223 }
224 else
225 XSETFASTINT (val, 0);
226 return val;
227 }
228 \f
229 static Lisp_Object
230 buildmark (EMACS_INT charpos, EMACS_INT bytepos)
231 {
232 register Lisp_Object mark;
233 mark = Fmake_marker ();
234 set_marker_both (mark, Qnil, charpos, bytepos);
235 return mark;
236 }
237
238 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
239 doc: /* Return value of point, as an integer.
240 Beginning of buffer is position (point-min). */)
241 (void)
242 {
243 Lisp_Object temp;
244 XSETFASTINT (temp, PT);
245 return temp;
246 }
247
248 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
249 doc: /* Return value of point, as a marker object. */)
250 (void)
251 {
252 return buildmark (PT, PT_BYTE);
253 }
254
255 EMACS_INT
256 clip_to_bounds (EMACS_INT lower, EMACS_INT num, EMACS_INT upper)
257 {
258 if (num < lower)
259 return lower;
260 else if (num > upper)
261 return upper;
262 else
263 return num;
264 }
265
266 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
267 doc: /* Set point to POSITION, a number or marker.
268 Beginning of buffer is position (point-min), end is (point-max).
269
270 The return value is POSITION. */)
271 (register Lisp_Object position)
272 {
273 EMACS_INT pos;
274
275 if (MARKERP (position)
276 && current_buffer == XMARKER (position)->buffer)
277 {
278 pos = marker_position (position);
279 if (pos < BEGV)
280 SET_PT_BOTH (BEGV, BEGV_BYTE);
281 else if (pos > ZV)
282 SET_PT_BOTH (ZV, ZV_BYTE);
283 else
284 SET_PT_BOTH (pos, marker_byte_position (position));
285
286 return position;
287 }
288
289 CHECK_NUMBER_COERCE_MARKER (position);
290
291 pos = clip_to_bounds (BEGV, XINT (position), ZV);
292 SET_PT (pos);
293 return position;
294 }
295
296
297 /* Return the start or end position of the region.
298 BEGINNINGP non-zero means return the start.
299 If there is no region active, signal an error. */
300
301 static Lisp_Object
302 region_limit (int beginningp)
303 {
304 Lisp_Object m;
305
306 if (!NILP (Vtransient_mark_mode)
307 && NILP (Vmark_even_if_inactive)
308 && NILP (BVAR (current_buffer, mark_active)))
309 xsignal0 (Qmark_inactive);
310
311 m = Fmarker_position (BVAR (current_buffer, mark));
312 if (NILP (m))
313 error ("The mark is not set now, so there is no region");
314
315 if ((PT < XFASTINT (m)) == (beginningp != 0))
316 m = make_number (PT);
317 return m;
318 }
319
320 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
321 doc: /* Return the integer value of point or mark, whichever is smaller. */)
322 (void)
323 {
324 return region_limit (1);
325 }
326
327 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
328 doc: /* Return the integer value of point or mark, whichever is larger. */)
329 (void)
330 {
331 return region_limit (0);
332 }
333
334 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
335 doc: /* Return this buffer's mark, as a marker object.
336 Watch out! Moving this marker changes the mark position.
337 If you set the marker not to point anywhere, the buffer will have no mark. */)
338 (void)
339 {
340 return BVAR (current_buffer, mark);
341 }
342
343 \f
344 /* Find all the overlays in the current buffer that touch position POS.
345 Return the number found, and store them in a vector in VEC
346 of length LEN. */
347
348 static int
349 overlays_around (EMACS_INT pos, Lisp_Object *vec, int len)
350 {
351 Lisp_Object overlay, start, end;
352 struct Lisp_Overlay *tail;
353 EMACS_INT startpos, endpos;
354 int idx = 0;
355
356 for (tail = current_buffer->overlays_before; tail; tail = tail->next)
357 {
358 XSETMISC (overlay, tail);
359
360 end = OVERLAY_END (overlay);
361 endpos = OVERLAY_POSITION (end);
362 if (endpos < pos)
363 break;
364 start = OVERLAY_START (overlay);
365 startpos = OVERLAY_POSITION (start);
366 if (startpos <= pos)
367 {
368 if (idx < len)
369 vec[idx] = overlay;
370 /* Keep counting overlays even if we can't return them all. */
371 idx++;
372 }
373 }
374
375 for (tail = current_buffer->overlays_after; tail; tail = tail->next)
376 {
377 XSETMISC (overlay, tail);
378
379 start = OVERLAY_START (overlay);
380 startpos = OVERLAY_POSITION (start);
381 if (pos < startpos)
382 break;
383 end = OVERLAY_END (overlay);
384 endpos = OVERLAY_POSITION (end);
385 if (pos <= endpos)
386 {
387 if (idx < len)
388 vec[idx] = overlay;
389 idx++;
390 }
391 }
392
393 return idx;
394 }
395
396 /* Return the value of property PROP, in OBJECT at POSITION.
397 It's the value of PROP that a char inserted at POSITION would get.
398 OBJECT is optional and defaults to the current buffer.
399 If OBJECT is a buffer, then overlay properties are considered as well as
400 text properties.
401 If OBJECT is a window, then that window's buffer is used, but
402 window-specific overlays are considered only if they are associated
403 with OBJECT. */
404 Lisp_Object
405 get_pos_property (Lisp_Object position, register Lisp_Object prop, Lisp_Object object)
406 {
407 CHECK_NUMBER_COERCE_MARKER (position);
408
409 if (NILP (object))
410 XSETBUFFER (object, current_buffer);
411 else if (WINDOWP (object))
412 object = XWINDOW (object)->buffer;
413
414 if (!BUFFERP (object))
415 /* pos-property only makes sense in buffers right now, since strings
416 have no overlays and no notion of insertion for which stickiness
417 could be obeyed. */
418 return Fget_text_property (position, prop, object);
419 else
420 {
421 EMACS_INT posn = XINT (position);
422 int noverlays;
423 Lisp_Object *overlay_vec, tem;
424 struct buffer *obuf = current_buffer;
425
426 set_buffer_temp (XBUFFER (object));
427
428 /* First try with room for 40 overlays. */
429 noverlays = 40;
430 overlay_vec = (Lisp_Object *) alloca (noverlays * sizeof (Lisp_Object));
431 noverlays = overlays_around (posn, overlay_vec, noverlays);
432
433 /* If there are more than 40,
434 make enough space for all, and try again. */
435 if (noverlays > 40)
436 {
437 overlay_vec = (Lisp_Object *) alloca (noverlays * sizeof (Lisp_Object));
438 noverlays = overlays_around (posn, overlay_vec, noverlays);
439 }
440 noverlays = sort_overlays (overlay_vec, noverlays, NULL);
441
442 set_buffer_temp (obuf);
443
444 /* Now check the overlays in order of decreasing priority. */
445 while (--noverlays >= 0)
446 {
447 Lisp_Object ol = overlay_vec[noverlays];
448 tem = Foverlay_get (ol, prop);
449 if (!NILP (tem))
450 {
451 /* Check the overlay is indeed active at point. */
452 Lisp_Object start = OVERLAY_START (ol), finish = OVERLAY_END (ol);
453 if ((OVERLAY_POSITION (start) == posn
454 && XMARKER (start)->insertion_type == 1)
455 || (OVERLAY_POSITION (finish) == posn
456 && XMARKER (finish)->insertion_type == 0))
457 ; /* The overlay will not cover a char inserted at point. */
458 else
459 {
460 return tem;
461 }
462 }
463 }
464
465 { /* Now check the text properties. */
466 int stickiness = text_property_stickiness (prop, position, object);
467 if (stickiness > 0)
468 return Fget_text_property (position, prop, object);
469 else if (stickiness < 0
470 && XINT (position) > BUF_BEGV (XBUFFER (object)))
471 return Fget_text_property (make_number (XINT (position) - 1),
472 prop, object);
473 else
474 return Qnil;
475 }
476 }
477 }
478
479 /* Find the field surrounding POS in *BEG and *END. If POS is nil,
480 the value of point is used instead. If BEG or END is null,
481 means don't store the beginning or end of the field.
482
483 BEG_LIMIT and END_LIMIT serve to limit the ranged of the returned
484 results; they do not effect boundary behavior.
485
486 If MERGE_AT_BOUNDARY is nonzero, then if POS is at the very first
487 position of a field, then the beginning of the previous field is
488 returned instead of the beginning of POS's field (since the end of a
489 field is actually also the beginning of the next input field, this
490 behavior is sometimes useful). Additionally in the MERGE_AT_BOUNDARY
491 true case, if two fields are separated by a field with the special
492 value `boundary', and POS lies within it, then the two separated
493 fields are considered to be adjacent, and POS between them, when
494 finding the beginning and ending of the "merged" field.
495
496 Either BEG or END may be 0, in which case the corresponding value
497 is not stored. */
498
499 static void
500 find_field (Lisp_Object pos, Lisp_Object merge_at_boundary,
501 Lisp_Object beg_limit,
502 EMACS_INT *beg, Lisp_Object end_limit, EMACS_INT *end)
503 {
504 /* Fields right before and after the point. */
505 Lisp_Object before_field, after_field;
506 /* 1 if POS counts as the start of a field. */
507 int at_field_start = 0;
508 /* 1 if POS counts as the end of a field. */
509 int at_field_end = 0;
510
511 if (NILP (pos))
512 XSETFASTINT (pos, PT);
513 else
514 CHECK_NUMBER_COERCE_MARKER (pos);
515
516 after_field
517 = get_char_property_and_overlay (pos, Qfield, Qnil, NULL);
518 before_field
519 = (XFASTINT (pos) > BEGV
520 ? get_char_property_and_overlay (make_number (XINT (pos) - 1),
521 Qfield, Qnil, NULL)
522 /* Using nil here would be a more obvious choice, but it would
523 fail when the buffer starts with a non-sticky field. */
524 : after_field);
525
526 /* See if we need to handle the case where MERGE_AT_BOUNDARY is nil
527 and POS is at beginning of a field, which can also be interpreted
528 as the end of the previous field. Note that the case where if
529 MERGE_AT_BOUNDARY is non-nil (see function comment) is actually the
530 more natural one; then we avoid treating the beginning of a field
531 specially. */
532 if (NILP (merge_at_boundary))
533 {
534 Lisp_Object field = get_pos_property (pos, Qfield, Qnil);
535 if (!EQ (field, after_field))
536 at_field_end = 1;
537 if (!EQ (field, before_field))
538 at_field_start = 1;
539 if (NILP (field) && at_field_start && at_field_end)
540 /* If an inserted char would have a nil field while the surrounding
541 text is non-nil, we're probably not looking at a
542 zero-length field, but instead at a non-nil field that's
543 not intended for editing (such as comint's prompts). */
544 at_field_end = at_field_start = 0;
545 }
546
547 /* Note about special `boundary' fields:
548
549 Consider the case where the point (`.') is between the fields `x' and `y':
550
551 xxxx.yyyy
552
553 In this situation, if merge_at_boundary is true, we consider the
554 `x' and `y' fields as forming one big merged field, and so the end
555 of the field is the end of `y'.
556
557 However, if `x' and `y' are separated by a special `boundary' field
558 (a field with a `field' char-property of 'boundary), then we ignore
559 this special field when merging adjacent fields. Here's the same
560 situation, but with a `boundary' field between the `x' and `y' fields:
561
562 xxx.BBBByyyy
563
564 Here, if point is at the end of `x', the beginning of `y', or
565 anywhere in-between (within the `boundary' field), we merge all
566 three fields and consider the beginning as being the beginning of
567 the `x' field, and the end as being the end of the `y' field. */
568
569 if (beg)
570 {
571 if (at_field_start)
572 /* POS is at the edge of a field, and we should consider it as
573 the beginning of the following field. */
574 *beg = XFASTINT (pos);
575 else
576 /* Find the previous field boundary. */
577 {
578 Lisp_Object p = pos;
579 if (!NILP (merge_at_boundary) && EQ (before_field, Qboundary))
580 /* Skip a `boundary' field. */
581 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
582 beg_limit);
583
584 p = Fprevious_single_char_property_change (p, Qfield, Qnil,
585 beg_limit);
586 *beg = NILP (p) ? BEGV : XFASTINT (p);
587 }
588 }
589
590 if (end)
591 {
592 if (at_field_end)
593 /* POS is at the edge of a field, and we should consider it as
594 the end of the previous field. */
595 *end = XFASTINT (pos);
596 else
597 /* Find the next field boundary. */
598 {
599 if (!NILP (merge_at_boundary) && EQ (after_field, Qboundary))
600 /* Skip a `boundary' field. */
601 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
602 end_limit);
603
604 pos = Fnext_single_char_property_change (pos, Qfield, Qnil,
605 end_limit);
606 *end = NILP (pos) ? ZV : XFASTINT (pos);
607 }
608 }
609 }
610
611 \f
612 DEFUN ("delete-field", Fdelete_field, Sdelete_field, 0, 1, 0,
613 doc: /* Delete the field surrounding POS.
614 A field is a region of text with the same `field' property.
615 If POS is nil, the value of point is used for POS. */)
616 (Lisp_Object pos)
617 {
618 EMACS_INT beg, end;
619 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
620 if (beg != end)
621 del_range (beg, end);
622 return Qnil;
623 }
624
625 DEFUN ("field-string", Ffield_string, Sfield_string, 0, 1, 0,
626 doc: /* Return the contents of the field surrounding POS as a string.
627 A field is a region of text with the same `field' property.
628 If POS is nil, the value of point is used for POS. */)
629 (Lisp_Object pos)
630 {
631 EMACS_INT beg, end;
632 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
633 return make_buffer_string (beg, end, 1);
634 }
635
636 DEFUN ("field-string-no-properties", Ffield_string_no_properties, Sfield_string_no_properties, 0, 1, 0,
637 doc: /* Return the contents of the field around POS, without text properties.
638 A field is a region of text with the same `field' property.
639 If POS is nil, the value of point is used for POS. */)
640 (Lisp_Object pos)
641 {
642 EMACS_INT beg, end;
643 find_field (pos, Qnil, Qnil, &beg, Qnil, &end);
644 return make_buffer_string (beg, end, 0);
645 }
646
647 DEFUN ("field-beginning", Ffield_beginning, Sfield_beginning, 0, 3, 0,
648 doc: /* Return the beginning of the field surrounding POS.
649 A field is a region of text with the same `field' property.
650 If POS is nil, the value of point is used for POS.
651 If ESCAPE-FROM-EDGE is non-nil and POS is at the beginning of its
652 field, then the beginning of the *previous* field is returned.
653 If LIMIT is non-nil, it is a buffer position; if the beginning of the field
654 is before LIMIT, then LIMIT will be returned instead. */)
655 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
656 {
657 EMACS_INT beg;
658 find_field (pos, escape_from_edge, limit, &beg, Qnil, 0);
659 return make_number (beg);
660 }
661
662 DEFUN ("field-end", Ffield_end, Sfield_end, 0, 3, 0,
663 doc: /* Return the end of the field surrounding POS.
664 A field is a region of text with the same `field' property.
665 If POS is nil, the value of point is used for POS.
666 If ESCAPE-FROM-EDGE is non-nil and POS is at the end of its field,
667 then the end of the *following* field is returned.
668 If LIMIT is non-nil, it is a buffer position; if the end of the field
669 is after LIMIT, then LIMIT will be returned instead. */)
670 (Lisp_Object pos, Lisp_Object escape_from_edge, Lisp_Object limit)
671 {
672 EMACS_INT end;
673 find_field (pos, escape_from_edge, Qnil, 0, limit, &end);
674 return make_number (end);
675 }
676
677 DEFUN ("constrain-to-field", Fconstrain_to_field, Sconstrain_to_field, 2, 5, 0,
678 doc: /* Return the position closest to NEW-POS that is in the same field as OLD-POS.
679
680 A field is a region of text with the same `field' property.
681 If NEW-POS is nil, then the current point is used instead, and set to the
682 constrained position if that is different.
683
684 If OLD-POS is at the boundary of two fields, then the allowable
685 positions for NEW-POS depends on the value of the optional argument
686 ESCAPE-FROM-EDGE: If ESCAPE-FROM-EDGE is nil, then NEW-POS is
687 constrained to the field that has the same `field' char-property
688 as any new characters inserted at OLD-POS, whereas if ESCAPE-FROM-EDGE
689 is non-nil, NEW-POS is constrained to the union of the two adjacent
690 fields. Additionally, if two fields are separated by another field with
691 the special value `boundary', then any point within this special field is
692 also considered to be `on the boundary'.
693
694 If the optional argument ONLY-IN-LINE is non-nil and constraining
695 NEW-POS would move it to a different line, NEW-POS is returned
696 unconstrained. This useful for commands that move by line, like
697 \\[next-line] or \\[beginning-of-line], which should generally respect field boundaries
698 only in the case where they can still move to the right line.
699
700 If the optional argument INHIBIT-CAPTURE-PROPERTY is non-nil, and OLD-POS has
701 a non-nil property of that name, then any field boundaries are ignored.
702
703 Field boundaries are not noticed if `inhibit-field-text-motion' is non-nil. */)
704 (Lisp_Object new_pos, Lisp_Object old_pos, Lisp_Object escape_from_edge, Lisp_Object only_in_line, Lisp_Object inhibit_capture_property)
705 {
706 /* If non-zero, then the original point, before re-positioning. */
707 EMACS_INT orig_point = 0;
708 int fwd;
709 Lisp_Object prev_old, prev_new;
710
711 if (NILP (new_pos))
712 /* Use the current point, and afterwards, set it. */
713 {
714 orig_point = PT;
715 XSETFASTINT (new_pos, PT);
716 }
717
718 CHECK_NUMBER_COERCE_MARKER (new_pos);
719 CHECK_NUMBER_COERCE_MARKER (old_pos);
720
721 fwd = (XFASTINT (new_pos) > XFASTINT (old_pos));
722
723 prev_old = make_number (XFASTINT (old_pos) - 1);
724 prev_new = make_number (XFASTINT (new_pos) - 1);
725
726 if (NILP (Vinhibit_field_text_motion)
727 && !EQ (new_pos, old_pos)
728 && (!NILP (Fget_char_property (new_pos, Qfield, Qnil))
729 || !NILP (Fget_char_property (old_pos, Qfield, Qnil))
730 /* To recognize field boundaries, we must also look at the
731 previous positions; we could use `get_pos_property'
732 instead, but in itself that would fail inside non-sticky
733 fields (like comint prompts). */
734 || (XFASTINT (new_pos) > BEGV
735 && !NILP (Fget_char_property (prev_new, Qfield, Qnil)))
736 || (XFASTINT (old_pos) > BEGV
737 && !NILP (Fget_char_property (prev_old, Qfield, Qnil))))
738 && (NILP (inhibit_capture_property)
739 /* Field boundaries are again a problem; but now we must
740 decide the case exactly, so we need to call
741 `get_pos_property' as well. */
742 || (NILP (get_pos_property (old_pos, inhibit_capture_property, Qnil))
743 && (XFASTINT (old_pos) <= BEGV
744 || NILP (Fget_char_property (old_pos, inhibit_capture_property, Qnil))
745 || NILP (Fget_char_property (prev_old, inhibit_capture_property, Qnil))))))
746 /* It is possible that NEW_POS is not within the same field as
747 OLD_POS; try to move NEW_POS so that it is. */
748 {
749 EMACS_INT shortage;
750 Lisp_Object field_bound;
751
752 if (fwd)
753 field_bound = Ffield_end (old_pos, escape_from_edge, new_pos);
754 else
755 field_bound = Ffield_beginning (old_pos, escape_from_edge, new_pos);
756
757 if (/* See if ESCAPE_FROM_EDGE caused FIELD_BOUND to jump to the
758 other side of NEW_POS, which would mean that NEW_POS is
759 already acceptable, and it's not necessary to constrain it
760 to FIELD_BOUND. */
761 ((XFASTINT (field_bound) < XFASTINT (new_pos)) ? fwd : !fwd)
762 /* NEW_POS should be constrained, but only if either
763 ONLY_IN_LINE is nil (in which case any constraint is OK),
764 or NEW_POS and FIELD_BOUND are on the same line (in which
765 case the constraint is OK even if ONLY_IN_LINE is non-nil). */
766 && (NILP (only_in_line)
767 /* This is the ONLY_IN_LINE case, check that NEW_POS and
768 FIELD_BOUND are on the same line by seeing whether
769 there's an intervening newline or not. */
770 || (scan_buffer ('\n',
771 XFASTINT (new_pos), XFASTINT (field_bound),
772 fwd ? -1 : 1, &shortage, 1),
773 shortage != 0)))
774 /* Constrain NEW_POS to FIELD_BOUND. */
775 new_pos = field_bound;
776
777 if (orig_point && XFASTINT (new_pos) != orig_point)
778 /* The NEW_POS argument was originally nil, so automatically set PT. */
779 SET_PT (XFASTINT (new_pos));
780 }
781
782 return new_pos;
783 }
784
785 \f
786 DEFUN ("line-beginning-position",
787 Fline_beginning_position, Sline_beginning_position, 0, 1, 0,
788 doc: /* Return the character position of the first character on the current line.
789 With argument N not nil or 1, move forward N - 1 lines first.
790 If scan reaches end of buffer, return that position.
791
792 The returned position is of the first character in the logical order,
793 i.e. the one that has the smallest character position.
794
795 This function constrains the returned position to the current field
796 unless that would be on a different line than the original,
797 unconstrained result. If N is nil or 1, and a front-sticky field
798 starts at point, the scan stops as soon as it starts. To ignore field
799 boundaries bind `inhibit-field-text-motion' to t.
800
801 This function does not move point. */)
802 (Lisp_Object n)
803 {
804 EMACS_INT orig, orig_byte, end;
805 int count = SPECPDL_INDEX ();
806 specbind (Qinhibit_point_motion_hooks, Qt);
807
808 if (NILP (n))
809 XSETFASTINT (n, 1);
810 else
811 CHECK_NUMBER (n);
812
813 orig = PT;
814 orig_byte = PT_BYTE;
815 Fforward_line (make_number (XINT (n) - 1));
816 end = PT;
817
818 SET_PT_BOTH (orig, orig_byte);
819
820 unbind_to (count, Qnil);
821
822 /* Return END constrained to the current input field. */
823 return Fconstrain_to_field (make_number (end), make_number (orig),
824 XINT (n) != 1 ? Qt : Qnil,
825 Qt, Qnil);
826 }
827
828 DEFUN ("line-end-position", Fline_end_position, Sline_end_position, 0, 1, 0,
829 doc: /* Return the character position of the last character on the current line.
830 With argument N not nil or 1, move forward N - 1 lines first.
831 If scan reaches end of buffer, return that position.
832
833 The returned position is of the last character in the logical order,
834 i.e. the character whose buffer position is the largest one.
835
836 This function constrains the returned position to the current field
837 unless that would be on a different line than the original,
838 unconstrained result. If N is nil or 1, and a rear-sticky field ends
839 at point, the scan stops as soon as it starts. To ignore field
840 boundaries bind `inhibit-field-text-motion' to t.
841
842 This function does not move point. */)
843 (Lisp_Object n)
844 {
845 EMACS_INT end_pos;
846 EMACS_INT orig = PT;
847
848 if (NILP (n))
849 XSETFASTINT (n, 1);
850 else
851 CHECK_NUMBER (n);
852
853 end_pos = find_before_next_newline (orig, 0, XINT (n) - (XINT (n) <= 0));
854
855 /* Return END_POS constrained to the current input field. */
856 return Fconstrain_to_field (make_number (end_pos), make_number (orig),
857 Qnil, Qt, Qnil);
858 }
859
860 \f
861 Lisp_Object
862 save_excursion_save (void)
863 {
864 int visible = (XBUFFER (XWINDOW (selected_window)->buffer)
865 == current_buffer);
866
867 return Fcons (Fpoint_marker (),
868 Fcons (Fcopy_marker (BVAR (current_buffer, mark), Qnil),
869 Fcons (visible ? Qt : Qnil,
870 Fcons (BVAR (current_buffer, mark_active),
871 selected_window))));
872 }
873
874 Lisp_Object
875 save_excursion_restore (Lisp_Object info)
876 {
877 Lisp_Object tem, tem1, omark, nmark;
878 struct gcpro gcpro1, gcpro2, gcpro3;
879 int visible_p;
880
881 tem = Fmarker_buffer (XCAR (info));
882 /* If buffer being returned to is now deleted, avoid error */
883 /* Otherwise could get error here while unwinding to top level
884 and crash */
885 /* In that case, Fmarker_buffer returns nil now. */
886 if (NILP (tem))
887 return Qnil;
888
889 omark = nmark = Qnil;
890 GCPRO3 (info, omark, nmark);
891
892 Fset_buffer (tem);
893
894 /* Point marker. */
895 tem = XCAR (info);
896 Fgoto_char (tem);
897 unchain_marker (XMARKER (tem));
898
899 /* Mark marker. */
900 info = XCDR (info);
901 tem = XCAR (info);
902 omark = Fmarker_position (BVAR (current_buffer, mark));
903 Fset_marker (BVAR (current_buffer, mark), tem, Fcurrent_buffer ());
904 nmark = Fmarker_position (tem);
905 unchain_marker (XMARKER (tem));
906
907 /* visible */
908 info = XCDR (info);
909 visible_p = !NILP (XCAR (info));
910
911 #if 0 /* We used to make the current buffer visible in the selected window
912 if that was true previously. That avoids some anomalies.
913 But it creates others, and it wasn't documented, and it is simpler
914 and cleaner never to alter the window/buffer connections. */
915 tem1 = Fcar (tem);
916 if (!NILP (tem1)
917 && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
918 Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
919 #endif /* 0 */
920
921 /* Mark active */
922 info = XCDR (info);
923 tem = XCAR (info);
924 tem1 = BVAR (current_buffer, mark_active);
925 BVAR (current_buffer, mark_active) = tem;
926
927 /* If mark is active now, and either was not active
928 or was at a different place, run the activate hook. */
929 if (! NILP (tem))
930 {
931 if (! EQ (omark, nmark))
932 {
933 tem = intern ("activate-mark-hook");
934 Frun_hooks (1, &tem);
935 }
936 }
937 /* If mark has ceased to be active, run deactivate hook. */
938 else if (! NILP (tem1))
939 {
940 tem = intern ("deactivate-mark-hook");
941 Frun_hooks (1, &tem);
942 }
943
944 /* If buffer was visible in a window, and a different window was
945 selected, and the old selected window is still showing this
946 buffer, restore point in that window. */
947 tem = XCDR (info);
948 if (visible_p
949 && !EQ (tem, selected_window)
950 && (tem1 = XWINDOW (tem)->buffer,
951 (/* Window is live... */
952 BUFFERP (tem1)
953 /* ...and it shows the current buffer. */
954 && XBUFFER (tem1) == current_buffer)))
955 Fset_window_point (tem, make_number (PT));
956
957 UNGCPRO;
958 return Qnil;
959 }
960
961 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
962 doc: /* Save point, mark, and current buffer; execute BODY; restore those things.
963 Executes BODY just like `progn'.
964 The values of point, mark and the current buffer are restored
965 even in case of abnormal exit (throw or error).
966 The state of activation of the mark is also restored.
967
968 This construct does not save `deactivate-mark', and therefore
969 functions that change the buffer will still cause deactivation
970 of the mark at the end of the command. To prevent that, bind
971 `deactivate-mark' with `let'.
972
973 If you only want to save the current buffer but not point nor mark,
974 then just use `save-current-buffer', or even `with-current-buffer'.
975
976 usage: (save-excursion &rest BODY) */)
977 (Lisp_Object args)
978 {
979 register Lisp_Object val;
980 int count = SPECPDL_INDEX ();
981
982 record_unwind_protect (save_excursion_restore, save_excursion_save ());
983
984 val = Fprogn (args);
985 return unbind_to (count, val);
986 }
987
988 DEFUN ("save-current-buffer", Fsave_current_buffer, Ssave_current_buffer, 0, UNEVALLED, 0,
989 doc: /* Save the current buffer; execute BODY; restore the current buffer.
990 Executes BODY just like `progn'.
991 usage: (save-current-buffer &rest BODY) */)
992 (Lisp_Object args)
993 {
994 Lisp_Object val;
995 int count = SPECPDL_INDEX ();
996
997 record_unwind_protect (set_buffer_if_live, Fcurrent_buffer ());
998
999 val = Fprogn (args);
1000 return unbind_to (count, val);
1001 }
1002 \f
1003 DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 1, 0,
1004 doc: /* Return the number of characters in the current buffer.
1005 If BUFFER, return the number of characters in that buffer instead. */)
1006 (Lisp_Object buffer)
1007 {
1008 if (NILP (buffer))
1009 return make_number (Z - BEG);
1010 else
1011 {
1012 CHECK_BUFFER (buffer);
1013 return make_number (BUF_Z (XBUFFER (buffer))
1014 - BUF_BEG (XBUFFER (buffer)));
1015 }
1016 }
1017
1018 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
1019 doc: /* Return the minimum permissible value of point in the current buffer.
1020 This is 1, unless narrowing (a buffer restriction) is in effect. */)
1021 (void)
1022 {
1023 Lisp_Object temp;
1024 XSETFASTINT (temp, BEGV);
1025 return temp;
1026 }
1027
1028 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
1029 doc: /* Return a marker to the minimum permissible value of point in this buffer.
1030 This is the beginning, unless narrowing (a buffer restriction) is in effect. */)
1031 (void)
1032 {
1033 return buildmark (BEGV, BEGV_BYTE);
1034 }
1035
1036 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
1037 doc: /* Return the maximum permissible value of point in the current buffer.
1038 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1039 is in effect, in which case it is less. */)
1040 (void)
1041 {
1042 Lisp_Object temp;
1043 XSETFASTINT (temp, ZV);
1044 return temp;
1045 }
1046
1047 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
1048 doc: /* Return a marker to the maximum permissible value of point in this buffer.
1049 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
1050 is in effect, in which case it is less. */)
1051 (void)
1052 {
1053 return buildmark (ZV, ZV_BYTE);
1054 }
1055
1056 DEFUN ("gap-position", Fgap_position, Sgap_position, 0, 0, 0,
1057 doc: /* Return the position of the gap, in the current buffer.
1058 See also `gap-size'. */)
1059 (void)
1060 {
1061 Lisp_Object temp;
1062 XSETFASTINT (temp, GPT);
1063 return temp;
1064 }
1065
1066 DEFUN ("gap-size", Fgap_size, Sgap_size, 0, 0, 0,
1067 doc: /* Return the size of the current buffer's gap.
1068 See also `gap-position'. */)
1069 (void)
1070 {
1071 Lisp_Object temp;
1072 XSETFASTINT (temp, GAP_SIZE);
1073 return temp;
1074 }
1075
1076 DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0,
1077 doc: /* Return the byte position for character position POSITION.
1078 If POSITION is out of range, the value is nil. */)
1079 (Lisp_Object position)
1080 {
1081 CHECK_NUMBER_COERCE_MARKER (position);
1082 if (XINT (position) < BEG || XINT (position) > Z)
1083 return Qnil;
1084 return make_number (CHAR_TO_BYTE (XINT (position)));
1085 }
1086
1087 DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0,
1088 doc: /* Return the character position for byte position BYTEPOS.
1089 If BYTEPOS is out of range, the value is nil. */)
1090 (Lisp_Object bytepos)
1091 {
1092 CHECK_NUMBER (bytepos);
1093 if (XINT (bytepos) < BEG_BYTE || XINT (bytepos) > Z_BYTE)
1094 return Qnil;
1095 return make_number (BYTE_TO_CHAR (XINT (bytepos)));
1096 }
1097 \f
1098 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
1099 doc: /* Return the character following point, as a number.
1100 At the end of the buffer or accessible region, return 0. */)
1101 (void)
1102 {
1103 Lisp_Object temp;
1104 if (PT >= ZV)
1105 XSETFASTINT (temp, 0);
1106 else
1107 XSETFASTINT (temp, FETCH_CHAR (PT_BYTE));
1108 return temp;
1109 }
1110
1111 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
1112 doc: /* Return the character preceding point, as a number.
1113 At the beginning of the buffer or accessible region, return 0. */)
1114 (void)
1115 {
1116 Lisp_Object temp;
1117 if (PT <= BEGV)
1118 XSETFASTINT (temp, 0);
1119 else if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1120 {
1121 EMACS_INT pos = PT_BYTE;
1122 DEC_POS (pos);
1123 XSETFASTINT (temp, FETCH_CHAR (pos));
1124 }
1125 else
1126 XSETFASTINT (temp, FETCH_BYTE (PT_BYTE - 1));
1127 return temp;
1128 }
1129
1130 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
1131 doc: /* Return t if point is at the beginning of the buffer.
1132 If the buffer is narrowed, this means the beginning of the narrowed part. */)
1133 (void)
1134 {
1135 if (PT == BEGV)
1136 return Qt;
1137 return Qnil;
1138 }
1139
1140 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
1141 doc: /* Return t if point is at the end of the buffer.
1142 If the buffer is narrowed, this means the end of the narrowed part. */)
1143 (void)
1144 {
1145 if (PT == ZV)
1146 return Qt;
1147 return Qnil;
1148 }
1149
1150 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
1151 doc: /* Return t if point is at the beginning of a line. */)
1152 (void)
1153 {
1154 if (PT == BEGV || FETCH_BYTE (PT_BYTE - 1) == '\n')
1155 return Qt;
1156 return Qnil;
1157 }
1158
1159 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
1160 doc: /* Return t if point is at the end of a line.
1161 `End of a line' includes point being at the end of the buffer. */)
1162 (void)
1163 {
1164 if (PT == ZV || FETCH_BYTE (PT_BYTE) == '\n')
1165 return Qt;
1166 return Qnil;
1167 }
1168
1169 DEFUN ("char-after", Fchar_after, Schar_after, 0, 1, 0,
1170 doc: /* Return character in current buffer at position POS.
1171 POS is an integer or a marker and defaults to point.
1172 If POS is out of range, the value is nil. */)
1173 (Lisp_Object pos)
1174 {
1175 register EMACS_INT pos_byte;
1176
1177 if (NILP (pos))
1178 {
1179 pos_byte = PT_BYTE;
1180 XSETFASTINT (pos, PT);
1181 }
1182
1183 if (MARKERP (pos))
1184 {
1185 pos_byte = marker_byte_position (pos);
1186 if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE)
1187 return Qnil;
1188 }
1189 else
1190 {
1191 CHECK_NUMBER_COERCE_MARKER (pos);
1192 if (XINT (pos) < BEGV || XINT (pos) >= ZV)
1193 return Qnil;
1194
1195 pos_byte = CHAR_TO_BYTE (XINT (pos));
1196 }
1197
1198 return make_number (FETCH_CHAR (pos_byte));
1199 }
1200
1201 DEFUN ("char-before", Fchar_before, Schar_before, 0, 1, 0,
1202 doc: /* Return character in current buffer preceding position POS.
1203 POS is an integer or a marker and defaults to point.
1204 If POS is out of range, the value is nil. */)
1205 (Lisp_Object pos)
1206 {
1207 register Lisp_Object val;
1208 register EMACS_INT pos_byte;
1209
1210 if (NILP (pos))
1211 {
1212 pos_byte = PT_BYTE;
1213 XSETFASTINT (pos, PT);
1214 }
1215
1216 if (MARKERP (pos))
1217 {
1218 pos_byte = marker_byte_position (pos);
1219
1220 if (pos_byte <= BEGV_BYTE || pos_byte > ZV_BYTE)
1221 return Qnil;
1222 }
1223 else
1224 {
1225 CHECK_NUMBER_COERCE_MARKER (pos);
1226
1227 if (XINT (pos) <= BEGV || XINT (pos) > ZV)
1228 return Qnil;
1229
1230 pos_byte = CHAR_TO_BYTE (XINT (pos));
1231 }
1232
1233 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
1234 {
1235 DEC_POS (pos_byte);
1236 XSETFASTINT (val, FETCH_CHAR (pos_byte));
1237 }
1238 else
1239 {
1240 pos_byte--;
1241 XSETFASTINT (val, FETCH_BYTE (pos_byte));
1242 }
1243 return val;
1244 }
1245 \f
1246 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
1247 doc: /* Return the name under which the user logged in, as a string.
1248 This is based on the effective uid, not the real uid.
1249 Also, if the environment variables LOGNAME or USER are set,
1250 that determines the value of this function.
1251
1252 If optional argument UID is an integer or a float, return the login name
1253 of the user with that uid, or nil if there is no such user. */)
1254 (Lisp_Object uid)
1255 {
1256 struct passwd *pw;
1257 uid_t id;
1258
1259 /* Set up the user name info if we didn't do it before.
1260 (That can happen if Emacs is dumpable
1261 but you decide to run `temacs -l loadup' and not dump. */
1262 if (INTEGERP (Vuser_login_name))
1263 init_editfns ();
1264
1265 if (NILP (uid))
1266 return Vuser_login_name;
1267
1268 id = XFLOATINT (uid);
1269 BLOCK_INPUT;
1270 pw = getpwuid (id);
1271 UNBLOCK_INPUT;
1272 return (pw ? build_string (pw->pw_name) : Qnil);
1273 }
1274
1275 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
1276 0, 0, 0,
1277 doc: /* Return the name of the user's real uid, as a string.
1278 This ignores the environment variables LOGNAME and USER, so it differs from
1279 `user-login-name' when running under `su'. */)
1280 (void)
1281 {
1282 /* Set up the user name info if we didn't do it before.
1283 (That can happen if Emacs is dumpable
1284 but you decide to run `temacs -l loadup' and not dump. */
1285 if (INTEGERP (Vuser_login_name))
1286 init_editfns ();
1287 return Vuser_real_login_name;
1288 }
1289
1290 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
1291 doc: /* Return the effective uid of Emacs.
1292 Value is an integer or a float, depending on the value. */)
1293 (void)
1294 {
1295 /* Assignment to EMACS_INT stops GCC whining about limited range of
1296 data type. */
1297 EMACS_INT euid = geteuid ();
1298
1299 /* Make sure we don't produce a negative UID due to signed integer
1300 overflow. */
1301 if (euid < 0)
1302 return make_float (geteuid ());
1303 return make_fixnum_or_float (euid);
1304 }
1305
1306 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
1307 doc: /* Return the real uid of Emacs.
1308 Value is an integer or a float, depending on the value. */)
1309 (void)
1310 {
1311 /* Assignment to EMACS_INT stops GCC whining about limited range of
1312 data type. */
1313 EMACS_INT uid = getuid ();
1314
1315 /* Make sure we don't produce a negative UID due to signed integer
1316 overflow. */
1317 if (uid < 0)
1318 return make_float (getuid ());
1319 return make_fixnum_or_float (uid);
1320 }
1321
1322 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0,
1323 doc: /* Return the full name of the user logged in, as a string.
1324 If the full name corresponding to Emacs's userid is not known,
1325 return "unknown".
1326
1327 If optional argument UID is an integer or float, return the full name
1328 of the user with that uid, or nil if there is no such user.
1329 If UID is a string, return the full name of the user with that login
1330 name, or nil if there is no such user. */)
1331 (Lisp_Object uid)
1332 {
1333 struct passwd *pw;
1334 register char *p, *q;
1335 Lisp_Object full;
1336
1337 if (NILP (uid))
1338 return Vuser_full_name;
1339 else if (NUMBERP (uid))
1340 {
1341 uid_t u = XFLOATINT (uid);
1342 BLOCK_INPUT;
1343 pw = getpwuid (u);
1344 UNBLOCK_INPUT;
1345 }
1346 else if (STRINGP (uid))
1347 {
1348 BLOCK_INPUT;
1349 pw = getpwnam (SSDATA (uid));
1350 UNBLOCK_INPUT;
1351 }
1352 else
1353 error ("Invalid UID specification");
1354
1355 if (!pw)
1356 return Qnil;
1357
1358 p = USER_FULL_NAME;
1359 /* Chop off everything after the first comma. */
1360 q = strchr (p, ',');
1361 full = make_string (p, q ? q - p : strlen (p));
1362
1363 #ifdef AMPERSAND_FULL_NAME
1364 p = SSDATA (full);
1365 q = strchr (p, '&');
1366 /* Substitute the login name for the &, upcasing the first character. */
1367 if (q)
1368 {
1369 register char *r;
1370 Lisp_Object login;
1371
1372 login = Fuser_login_name (make_number (pw->pw_uid));
1373 r = (char *) alloca (strlen (p) + SCHARS (login) + 1);
1374 memcpy (r, p, q - p);
1375 r[q - p] = 0;
1376 strcat (r, SSDATA (login));
1377 r[q - p] = upcase ((unsigned char) r[q - p]);
1378 strcat (r, q + 1);
1379 full = build_string (r);
1380 }
1381 #endif /* AMPERSAND_FULL_NAME */
1382
1383 return full;
1384 }
1385
1386 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
1387 doc: /* Return the host name of the machine you are running on, as a string. */)
1388 (void)
1389 {
1390 return Vsystem_name;
1391 }
1392
1393 const char *
1394 get_system_name (void)
1395 {
1396 if (STRINGP (Vsystem_name))
1397 return SSDATA (Vsystem_name);
1398 else
1399 return "";
1400 }
1401
1402 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
1403 doc: /* Return the process ID of Emacs, as an integer. */)
1404 (void)
1405 {
1406 return make_number (getpid ());
1407 }
1408
1409 \f
1410
1411 #ifndef TIME_T_MIN
1412 # define TIME_T_MIN TYPE_MINIMUM (time_t)
1413 #endif
1414 #ifndef TIME_T_MAX
1415 # define TIME_T_MAX TYPE_MAXIMUM (time_t)
1416 #endif
1417
1418 /* Report that a time value is out of range for Emacs. */
1419 static void
1420 time_overflow (void)
1421 {
1422 error ("Specified time is not representable");
1423 }
1424
1425 /* Return the upper part of the time T (everything but the bottom 16 bits),
1426 making sure that it is representable. */
1427 static EMACS_INT
1428 hi_time (time_t t)
1429 {
1430 time_t hi = t >> 16;
1431
1432 /* Check for overflow, helping the compiler for common cases where
1433 no runtime check is needed, and taking care not to convert
1434 negative numbers to unsigned before comparing them. */
1435 if (! ((! TYPE_SIGNED (time_t)
1436 || MOST_NEGATIVE_FIXNUM <= TIME_T_MIN >> 16
1437 || MOST_NEGATIVE_FIXNUM <= hi)
1438 && (TIME_T_MAX >> 16 <= MOST_POSITIVE_FIXNUM
1439 || hi <= MOST_POSITIVE_FIXNUM)))
1440 time_overflow ();
1441
1442 return hi;
1443 }
1444
1445 /* Return the bottom 16 bits of the time T. */
1446 static EMACS_INT
1447 lo_time (time_t t)
1448 {
1449 return t & ((1 << 16) - 1);
1450 }
1451
1452 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
1453 doc: /* Return the current time, as the number of seconds since 1970-01-01 00:00:00.
1454 The time is returned as a list of three integers. The first has the
1455 most significant 16 bits of the seconds, while the second has the
1456 least significant 16 bits. The third integer gives the microsecond
1457 count.
1458
1459 The microsecond count is zero on systems that do not provide
1460 resolution finer than a second. */)
1461 (void)
1462 {
1463 EMACS_TIME t;
1464
1465 EMACS_GET_TIME (t);
1466 return list3 (make_number (hi_time (EMACS_SECS (t))),
1467 make_number (lo_time (EMACS_SECS (t))),
1468 make_number (EMACS_USECS (t)));
1469 }
1470
1471 DEFUN ("get-internal-run-time", Fget_internal_run_time, Sget_internal_run_time,
1472 0, 0, 0,
1473 doc: /* Return the current run time used by Emacs.
1474 The time is returned as a list of three integers. The first has the
1475 most significant 16 bits of the seconds, while the second has the
1476 least significant 16 bits. The third integer gives the microsecond
1477 count.
1478
1479 On systems that can't determine the run time, `get-internal-run-time'
1480 does the same thing as `current-time'. The microsecond count is zero
1481 on systems that do not provide resolution finer than a second. */)
1482 (void)
1483 {
1484 #ifdef HAVE_GETRUSAGE
1485 struct rusage usage;
1486 time_t secs;
1487 int usecs;
1488
1489 if (getrusage (RUSAGE_SELF, &usage) < 0)
1490 /* This shouldn't happen. What action is appropriate? */
1491 xsignal0 (Qerror);
1492
1493 /* Sum up user time and system time. */
1494 secs = usage.ru_utime.tv_sec + usage.ru_stime.tv_sec;
1495 usecs = usage.ru_utime.tv_usec + usage.ru_stime.tv_usec;
1496 if (usecs >= 1000000)
1497 {
1498 usecs -= 1000000;
1499 secs++;
1500 }
1501
1502 return list3 (make_number (hi_time (secs)),
1503 make_number (lo_time (secs)),
1504 make_number (usecs));
1505 #else /* ! HAVE_GETRUSAGE */
1506 #ifdef WINDOWSNT
1507 return w32_get_internal_run_time ();
1508 #else /* ! WINDOWSNT */
1509 return Fcurrent_time ();
1510 #endif /* WINDOWSNT */
1511 #endif /* HAVE_GETRUSAGE */
1512 }
1513 \f
1514
1515 /* Make a Lisp list that represents the time T. */
1516 Lisp_Object
1517 make_time (time_t t)
1518 {
1519 return list2 (make_number (hi_time (t)),
1520 make_number (lo_time (t)));
1521 }
1522
1523 /* Decode a Lisp list SPECIFIED_TIME that represents a time.
1524 If SPECIFIED_TIME is nil, use the current time.
1525 Set *RESULT to seconds since the Epoch.
1526 If USEC is not null, set *USEC to the microseconds component.
1527 Return nonzero if successful. */
1528 int
1529 lisp_time_argument (Lisp_Object specified_time, time_t *result, int *usec)
1530 {
1531 if (NILP (specified_time))
1532 {
1533 if (usec)
1534 {
1535 EMACS_TIME t;
1536
1537 EMACS_GET_TIME (t);
1538 *usec = EMACS_USECS (t);
1539 *result = EMACS_SECS (t);
1540 return 1;
1541 }
1542 else
1543 return time (result) != -1;
1544 }
1545 else
1546 {
1547 Lisp_Object high, low;
1548 EMACS_INT hi;
1549 high = Fcar (specified_time);
1550 CHECK_NUMBER (high);
1551 low = Fcdr (specified_time);
1552 if (CONSP (low))
1553 {
1554 if (usec)
1555 {
1556 Lisp_Object usec_l = Fcdr (low);
1557 if (CONSP (usec_l))
1558 usec_l = Fcar (usec_l);
1559 if (NILP (usec_l))
1560 *usec = 0;
1561 else
1562 {
1563 CHECK_NUMBER (usec_l);
1564 *usec = XINT (usec_l);
1565 }
1566 }
1567 low = Fcar (low);
1568 }
1569 else if (usec)
1570 *usec = 0;
1571 CHECK_NUMBER (low);
1572 hi = XINT (high);
1573
1574 /* Check for overflow, helping the compiler for common cases
1575 where no runtime check is needed, and taking care not to
1576 convert negative numbers to unsigned before comparing them. */
1577 if (! ((TYPE_SIGNED (time_t)
1578 ? (TIME_T_MIN >> 16 <= MOST_NEGATIVE_FIXNUM
1579 || TIME_T_MIN >> 16 <= hi)
1580 : 0 <= hi)
1581 && (MOST_POSITIVE_FIXNUM <= TIME_T_MAX >> 16
1582 || hi <= TIME_T_MAX >> 16)))
1583 return 0;
1584
1585 *result = (hi << 16) + (XINT (low) & 0xffff);
1586 return 1;
1587 }
1588 }
1589
1590 DEFUN ("float-time", Ffloat_time, Sfloat_time, 0, 1, 0,
1591 doc: /* Return the current time, as a float number of seconds since the epoch.
1592 If SPECIFIED-TIME is given, it is the time to convert to float
1593 instead of the current time. The argument should have the form
1594 (HIGH LOW) or (HIGH LOW USEC). Thus, you can use times obtained from
1595 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1596 have the form (HIGH . LOW), but this is considered obsolete.
1597
1598 WARNING: Since the result is floating point, it may not be exact.
1599 If precise time stamps are required, use either `current-time',
1600 or (if you need time as a string) `format-time-string'. */)
1601 (Lisp_Object specified_time)
1602 {
1603 time_t sec;
1604 int usec;
1605
1606 if (! lisp_time_argument (specified_time, &sec, &usec))
1607 error ("Invalid time specification");
1608
1609 return make_float ((sec * 1e6 + usec) / 1e6);
1610 }
1611
1612 /* Write information into buffer S of size MAXSIZE, according to the
1613 FORMAT of length FORMAT_LEN, using time information taken from *TP.
1614 Default to Universal Time if UT is nonzero, local time otherwise.
1615 Use NS as the number of nanoseconds in the %N directive.
1616 Return the number of bytes written, not including the terminating
1617 '\0'. If S is NULL, nothing will be written anywhere; so to
1618 determine how many bytes would be written, use NULL for S and
1619 ((size_t) -1) for MAXSIZE.
1620
1621 This function behaves like nstrftime, except it allows null
1622 bytes in FORMAT and it does not support nanoseconds. */
1623 static size_t
1624 emacs_nmemftime (char *s, size_t maxsize, const char *format,
1625 size_t format_len, const struct tm *tp, int ut, int ns)
1626 {
1627 size_t total = 0;
1628
1629 /* Loop through all the null-terminated strings in the format
1630 argument. Normally there's just one null-terminated string, but
1631 there can be arbitrarily many, concatenated together, if the
1632 format contains '\0' bytes. nstrftime stops at the first
1633 '\0' byte so we must invoke it separately for each such string. */
1634 for (;;)
1635 {
1636 size_t len;
1637 size_t result;
1638
1639 if (s)
1640 s[0] = '\1';
1641
1642 result = nstrftime (s, maxsize, format, tp, ut, ns);
1643
1644 if (s)
1645 {
1646 if (result == 0 && s[0] != '\0')
1647 return 0;
1648 s += result + 1;
1649 }
1650
1651 maxsize -= result + 1;
1652 total += result;
1653 len = strlen (format);
1654 if (len == format_len)
1655 return total;
1656 total++;
1657 format += len + 1;
1658 format_len -= len + 1;
1659 }
1660 }
1661
1662 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 3, 0,
1663 doc: /* Use FORMAT-STRING to format the time TIME, or now if omitted.
1664 TIME is specified as (HIGH LOW . IGNORED), as returned by
1665 `current-time' or `file-attributes'. The obsolete form (HIGH . LOW)
1666 is also still accepted.
1667 The third, optional, argument UNIVERSAL, if non-nil, means describe TIME
1668 as Universal Time; nil means describe TIME in the local time zone.
1669 The value is a copy of FORMAT-STRING, but with certain constructs replaced
1670 by text that describes the specified date and time in TIME:
1671
1672 %Y is the year, %y within the century, %C the century.
1673 %G is the year corresponding to the ISO week, %g within the century.
1674 %m is the numeric month.
1675 %b and %h are the locale's abbreviated month name, %B the full name.
1676 %d is the day of the month, zero-padded, %e is blank-padded.
1677 %u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6.
1678 %a is the locale's abbreviated name of the day of week, %A the full name.
1679 %U is the week number starting on Sunday, %W starting on Monday,
1680 %V according to ISO 8601.
1681 %j is the day of the year.
1682
1683 %H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H
1684 only blank-padded, %l is like %I blank-padded.
1685 %p is the locale's equivalent of either AM or PM.
1686 %M is the minute.
1687 %S is the second.
1688 %N is the nanosecond, %6N the microsecond, %3N the millisecond, etc.
1689 %Z is the time zone name, %z is the numeric form.
1690 %s is the number of seconds since 1970-01-01 00:00:00 +0000.
1691
1692 %c is the locale's date and time format.
1693 %x is the locale's "preferred" date format.
1694 %D is like "%m/%d/%y".
1695
1696 %R is like "%H:%M", %T is like "%H:%M:%S", %r is like "%I:%M:%S %p".
1697 %X is the locale's "preferred" time format.
1698
1699 Finally, %n is a newline, %t is a tab, %% is a literal %.
1700
1701 Certain flags and modifiers are available with some format controls.
1702 The flags are `_', `-', `^' and `#'. For certain characters X,
1703 %_X is like %X, but padded with blanks; %-X is like %X,
1704 but without padding. %^X is like %X, but with all textual
1705 characters up-cased; %#X is like %X, but with letter-case of
1706 all textual characters reversed.
1707 %NX (where N stands for an integer) is like %X,
1708 but takes up at least N (a number) positions.
1709 The modifiers are `E' and `O'. For certain characters X,
1710 %EX is a locale's alternative version of %X;
1711 %OX is like %X, but uses the locale's number symbols.
1712
1713 For example, to produce full ISO 8601 format, use "%Y-%m-%dT%T%z". */)
1714 (Lisp_Object format_string, Lisp_Object timeval, Lisp_Object universal)
1715 {
1716 time_t value;
1717 int size;
1718 int usec;
1719 int ns;
1720 struct tm *tm;
1721 int ut = ! NILP (universal);
1722
1723 CHECK_STRING (format_string);
1724
1725 if (! (lisp_time_argument (timeval, &value, &usec)
1726 && 0 <= usec && usec < 1000000))
1727 error ("Invalid time specification");
1728 ns = usec * 1000;
1729
1730 format_string = code_convert_string_norecord (format_string,
1731 Vlocale_coding_system, 1);
1732
1733 /* This is probably enough. */
1734 size = SBYTES (format_string) * 6 + 50;
1735
1736 BLOCK_INPUT;
1737 tm = ut ? gmtime (&value) : localtime (&value);
1738 UNBLOCK_INPUT;
1739 if (! tm)
1740 time_overflow ();
1741
1742 synchronize_system_time_locale ();
1743
1744 while (1)
1745 {
1746 char *buf = (char *) alloca (size + 1);
1747 int result;
1748
1749 buf[0] = '\1';
1750 BLOCK_INPUT;
1751 result = emacs_nmemftime (buf, size, SSDATA (format_string),
1752 SBYTES (format_string),
1753 tm, ut, ns);
1754 UNBLOCK_INPUT;
1755 if ((result > 0 && result < size) || (result == 0 && buf[0] == '\0'))
1756 return code_convert_string_norecord (make_unibyte_string (buf, result),
1757 Vlocale_coding_system, 0);
1758
1759 /* If buffer was too small, make it bigger and try again. */
1760 BLOCK_INPUT;
1761 result = emacs_nmemftime (NULL, (size_t) -1,
1762 SSDATA (format_string),
1763 SBYTES (format_string),
1764 tm, ut, ns);
1765 UNBLOCK_INPUT;
1766 size = result + 1;
1767 }
1768 }
1769
1770 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0,
1771 doc: /* Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1772 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED),
1773 as from `current-time' and `file-attributes', or nil to use the
1774 current time. The obsolete form (HIGH . LOW) is also still accepted.
1775 The list has the following nine members: SEC is an integer between 0
1776 and 60; SEC is 60 for a leap second, which only some operating systems
1777 support. MINUTE is an integer between 0 and 59. HOUR is an integer
1778 between 0 and 23. DAY is an integer between 1 and 31. MONTH is an
1779 integer between 1 and 12. YEAR is an integer indicating the
1780 four-digit year. DOW is the day of week, an integer between 0 and 6,
1781 where 0 is Sunday. DST is t if daylight saving time is in effect,
1782 otherwise nil. ZONE is an integer indicating the number of seconds
1783 east of Greenwich. (Note that Common Lisp has different meanings for
1784 DOW and ZONE.) */)
1785 (Lisp_Object specified_time)
1786 {
1787 time_t time_spec;
1788 struct tm save_tm;
1789 struct tm *decoded_time;
1790 Lisp_Object list_args[9];
1791
1792 if (! lisp_time_argument (specified_time, &time_spec, NULL))
1793 error ("Invalid time specification");
1794
1795 BLOCK_INPUT;
1796 decoded_time = localtime (&time_spec);
1797 UNBLOCK_INPUT;
1798 if (! (decoded_time
1799 && MOST_NEGATIVE_FIXNUM - TM_YEAR_BASE <= decoded_time->tm_year
1800 && decoded_time->tm_year <= MOST_POSITIVE_FIXNUM - TM_YEAR_BASE))
1801 time_overflow ();
1802 XSETFASTINT (list_args[0], decoded_time->tm_sec);
1803 XSETFASTINT (list_args[1], decoded_time->tm_min);
1804 XSETFASTINT (list_args[2], decoded_time->tm_hour);
1805 XSETFASTINT (list_args[3], decoded_time->tm_mday);
1806 XSETFASTINT (list_args[4], decoded_time->tm_mon + 1);
1807 /* On 64-bit machines an int is narrower than EMACS_INT, thus the
1808 cast below avoids overflow in int arithmetics. */
1809 XSETINT (list_args[5], TM_YEAR_BASE + (EMACS_INT) decoded_time->tm_year);
1810 XSETFASTINT (list_args[6], decoded_time->tm_wday);
1811 list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil;
1812
1813 /* Make a copy, in case gmtime modifies the struct. */
1814 save_tm = *decoded_time;
1815 BLOCK_INPUT;
1816 decoded_time = gmtime (&time_spec);
1817 UNBLOCK_INPUT;
1818 if (decoded_time == 0)
1819 list_args[8] = Qnil;
1820 else
1821 XSETINT (list_args[8], tm_diff (&save_tm, decoded_time));
1822 return Flist (9, list_args);
1823 }
1824
1825 /* Return OBJ - OFFSET, checking that OBJ is a valid fixnum and that
1826 the result is representable as an int. Assume OFFSET is small and
1827 nonnegative. */
1828 static int
1829 check_tm_member (Lisp_Object obj, int offset)
1830 {
1831 EMACS_INT n;
1832 CHECK_NUMBER (obj);
1833 n = XINT (obj);
1834 if (! (INT_MIN + offset <= n && n - offset <= INT_MAX))
1835 time_overflow ();
1836 return n - offset;
1837 }
1838
1839 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0,
1840 doc: /* Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1841 This is the reverse operation of `decode-time', which see.
1842 ZONE defaults to the current time zone rule. This can
1843 be a string or t (as from `set-time-zone-rule'), or it can be a list
1844 \(as from `current-time-zone') or an integer (as from `decode-time')
1845 applied without consideration for daylight saving time.
1846
1847 You can pass more than 7 arguments; then the first six arguments
1848 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1849 The intervening arguments are ignored.
1850 This feature lets (apply 'encode-time (decode-time ...)) work.
1851
1852 Out-of-range values for SECOND, MINUTE, HOUR, DAY, or MONTH are allowed;
1853 for example, a DAY of 0 means the day preceding the given month.
1854 Year numbers less than 100 are treated just like other year numbers.
1855 If you want them to stand for years in this century, you must do that yourself.
1856
1857 Years before 1970 are not guaranteed to work. On some systems,
1858 year values as low as 1901 do work.
1859
1860 usage: (encode-time SECOND MINUTE HOUR DAY MONTH YEAR &optional ZONE) */)
1861 (ptrdiff_t nargs, Lisp_Object *args)
1862 {
1863 time_t value;
1864 struct tm tm;
1865 Lisp_Object zone = (nargs > 6 ? args[nargs - 1] : Qnil);
1866
1867 tm.tm_sec = check_tm_member (args[0], 0);
1868 tm.tm_min = check_tm_member (args[1], 0);
1869 tm.tm_hour = check_tm_member (args[2], 0);
1870 tm.tm_mday = check_tm_member (args[3], 0);
1871 tm.tm_mon = check_tm_member (args[4], 1);
1872 tm.tm_year = check_tm_member (args[5], TM_YEAR_BASE);
1873 tm.tm_isdst = -1;
1874
1875 if (CONSP (zone))
1876 zone = Fcar (zone);
1877 if (NILP (zone))
1878 {
1879 BLOCK_INPUT;
1880 value = mktime (&tm);
1881 UNBLOCK_INPUT;
1882 }
1883 else
1884 {
1885 char tzbuf[100];
1886 const char *tzstring;
1887 char **oldenv = environ, **newenv;
1888
1889 if (EQ (zone, Qt))
1890 tzstring = "UTC0";
1891 else if (STRINGP (zone))
1892 tzstring = SSDATA (zone);
1893 else if (INTEGERP (zone))
1894 {
1895 int abszone = eabs (XINT (zone));
1896 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0),
1897 abszone / (60*60), (abszone/60) % 60, abszone % 60);
1898 tzstring = tzbuf;
1899 }
1900 else
1901 error ("Invalid time zone specification");
1902
1903 /* Set TZ before calling mktime; merely adjusting mktime's returned
1904 value doesn't suffice, since that would mishandle leap seconds. */
1905 set_time_zone_rule (tzstring);
1906
1907 BLOCK_INPUT;
1908 value = mktime (&tm);
1909 UNBLOCK_INPUT;
1910
1911 /* Restore TZ to previous value. */
1912 newenv = environ;
1913 environ = oldenv;
1914 xfree (newenv);
1915 #ifdef LOCALTIME_CACHE
1916 tzset ();
1917 #endif
1918 }
1919
1920 if (value == (time_t) -1)
1921 time_overflow ();
1922
1923 return make_time (value);
1924 }
1925
1926 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
1927 doc: /* Return the current local time, as a human-readable string.
1928 Programs can use this function to decode a time,
1929 since the number of columns in each field is fixed
1930 if the year is in the range 1000-9999.
1931 The format is `Sun Sep 16 01:03:52 1973'.
1932 However, see also the functions `decode-time' and `format-time-string'
1933 which provide a much more powerful and general facility.
1934
1935 If SPECIFIED-TIME is given, it is a time to format instead of the
1936 current time. The argument should have the form (HIGH LOW . IGNORED).
1937 Thus, you can use times obtained from `current-time' and from
1938 `file-attributes'. SPECIFIED-TIME can also have the form (HIGH . LOW),
1939 but this is considered obsolete. */)
1940 (Lisp_Object specified_time)
1941 {
1942 time_t value;
1943 struct tm *tm;
1944 register char *tem;
1945
1946 if (! lisp_time_argument (specified_time, &value, NULL))
1947 error ("Invalid time specification");
1948
1949 /* Convert to a string, checking for out-of-range time stamps.
1950 Don't use 'ctime', as that might dump core if VALUE is out of
1951 range. */
1952 BLOCK_INPUT;
1953 tm = localtime (&value);
1954 UNBLOCK_INPUT;
1955 if (! (tm && TM_YEAR_IN_ASCTIME_RANGE (tm->tm_year) && (tem = asctime (tm))))
1956 time_overflow ();
1957
1958 /* Remove the trailing newline. */
1959 tem[strlen (tem) - 1] = '\0';
1960
1961 return build_string (tem);
1962 }
1963
1964 /* Yield A - B, measured in seconds.
1965 This function is copied from the GNU C Library. */
1966 static int
1967 tm_diff (struct tm *a, struct tm *b)
1968 {
1969 /* Compute intervening leap days correctly even if year is negative.
1970 Take care to avoid int overflow in leap day calculations,
1971 but it's OK to assume that A and B are close to each other. */
1972 int a4 = (a->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (a->tm_year & 3);
1973 int b4 = (b->tm_year >> 2) + (TM_YEAR_BASE >> 2) - ! (b->tm_year & 3);
1974 int a100 = a4 / 25 - (a4 % 25 < 0);
1975 int b100 = b4 / 25 - (b4 % 25 < 0);
1976 int a400 = a100 >> 2;
1977 int b400 = b100 >> 2;
1978 int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
1979 int years = a->tm_year - b->tm_year;
1980 int days = (365 * years + intervening_leap_days
1981 + (a->tm_yday - b->tm_yday));
1982 return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
1983 + (a->tm_min - b->tm_min))
1984 + (a->tm_sec - b->tm_sec));
1985 }
1986
1987 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
1988 doc: /* Return the offset and name for the local time zone.
1989 This returns a list of the form (OFFSET NAME).
1990 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1991 A negative value means west of Greenwich.
1992 NAME is a string giving the name of the time zone.
1993 If SPECIFIED-TIME is given, the time zone offset is determined from it
1994 instead of using the current time. The argument should have the form
1995 (HIGH LOW . IGNORED). Thus, you can use times obtained from
1996 `current-time' and from `file-attributes'. SPECIFIED-TIME can also
1997 have the form (HIGH . LOW), but this is considered obsolete.
1998
1999 Some operating systems cannot provide all this information to Emacs;
2000 in this case, `current-time-zone' returns a list containing nil for
2001 the data it can't find. */)
2002 (Lisp_Object specified_time)
2003 {
2004 time_t value;
2005 struct tm *t;
2006 struct tm gmt;
2007
2008 if (!lisp_time_argument (specified_time, &value, NULL))
2009 t = NULL;
2010 else
2011 {
2012 BLOCK_INPUT;
2013 t = gmtime (&value);
2014 if (t)
2015 {
2016 gmt = *t;
2017 t = localtime (&value);
2018 }
2019 UNBLOCK_INPUT;
2020 }
2021
2022 if (t)
2023 {
2024 int offset = tm_diff (t, &gmt);
2025 char *s = 0;
2026 char buf[6];
2027
2028 #ifdef HAVE_TM_ZONE
2029 if (t->tm_zone)
2030 s = (char *)t->tm_zone;
2031 #else /* not HAVE_TM_ZONE */
2032 #ifdef HAVE_TZNAME
2033 if (t->tm_isdst == 0 || t->tm_isdst == 1)
2034 s = tzname[t->tm_isdst];
2035 #endif
2036 #endif /* not HAVE_TM_ZONE */
2037
2038 if (!s)
2039 {
2040 /* No local time zone name is available; use "+-NNNN" instead. */
2041 int am = (offset < 0 ? -offset : offset) / 60;
2042 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
2043 s = buf;
2044 }
2045
2046 return Fcons (make_number (offset), Fcons (build_string (s), Qnil));
2047 }
2048 else
2049 return Fmake_list (make_number (2), Qnil);
2050 }
2051
2052 /* This holds the value of `environ' produced by the previous
2053 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
2054 has never been called. */
2055 static char **environbuf;
2056
2057 /* This holds the startup value of the TZ environment variable so it
2058 can be restored if the user calls set-time-zone-rule with a nil
2059 argument. */
2060 static char *initial_tz;
2061
2062 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
2063 doc: /* Set the local time zone using TZ, a string specifying a time zone rule.
2064 If TZ is nil, use implementation-defined default time zone information.
2065 If TZ is t, use Universal Time. */)
2066 (Lisp_Object tz)
2067 {
2068 const char *tzstring;
2069
2070 /* When called for the first time, save the original TZ. */
2071 if (!environbuf)
2072 initial_tz = (char *) getenv ("TZ");
2073
2074 if (NILP (tz))
2075 tzstring = initial_tz;
2076 else if (EQ (tz, Qt))
2077 tzstring = "UTC0";
2078 else
2079 {
2080 CHECK_STRING (tz);
2081 tzstring = SSDATA (tz);
2082 }
2083
2084 set_time_zone_rule (tzstring);
2085 free (environbuf);
2086 environbuf = environ;
2087
2088 return Qnil;
2089 }
2090
2091 #ifdef LOCALTIME_CACHE
2092
2093 /* These two values are known to load tz files in buggy implementations,
2094 i.e. Solaris 1 executables running under either Solaris 1 or Solaris 2.
2095 Their values shouldn't matter in non-buggy implementations.
2096 We don't use string literals for these strings,
2097 since if a string in the environment is in readonly
2098 storage, it runs afoul of bugs in SVR4 and Solaris 2.3.
2099 See Sun bugs 1113095 and 1114114, ``Timezone routines
2100 improperly modify environment''. */
2101
2102 static char set_time_zone_rule_tz1[] = "TZ=GMT+0";
2103 static char set_time_zone_rule_tz2[] = "TZ=GMT+1";
2104
2105 #endif
2106
2107 /* Set the local time zone rule to TZSTRING.
2108 This allocates memory into `environ', which it is the caller's
2109 responsibility to free. */
2110
2111 void
2112 set_time_zone_rule (const char *tzstring)
2113 {
2114 int envptrs;
2115 char **from, **to, **newenv;
2116
2117 /* Make the ENVIRON vector longer with room for TZSTRING. */
2118 for (from = environ; *from; from++)
2119 continue;
2120 envptrs = from - environ + 2;
2121 newenv = to = (char **) xmalloc (envptrs * sizeof (char *)
2122 + (tzstring ? strlen (tzstring) + 4 : 0));
2123
2124 /* Add TZSTRING to the end of environ, as a value for TZ. */
2125 if (tzstring)
2126 {
2127 char *t = (char *) (to + envptrs);
2128 strcpy (t, "TZ=");
2129 strcat (t, tzstring);
2130 *to++ = t;
2131 }
2132
2133 /* Copy the old environ vector elements into NEWENV,
2134 but don't copy the TZ variable.
2135 So we have only one definition of TZ, which came from TZSTRING. */
2136 for (from = environ; *from; from++)
2137 if (strncmp (*from, "TZ=", 3) != 0)
2138 *to++ = *from;
2139 *to = 0;
2140
2141 environ = newenv;
2142
2143 /* If we do have a TZSTRING, NEWENV points to the vector slot where
2144 the TZ variable is stored. If we do not have a TZSTRING,
2145 TO points to the vector slot which has the terminating null. */
2146
2147 #ifdef LOCALTIME_CACHE
2148 {
2149 /* In SunOS 4.1.3_U1 and 4.1.4, if TZ has a value like
2150 "US/Pacific" that loads a tz file, then changes to a value like
2151 "XXX0" that does not load a tz file, and then changes back to
2152 its original value, the last change is (incorrectly) ignored.
2153 Also, if TZ changes twice in succession to values that do
2154 not load a tz file, tzset can dump core (see Sun bug#1225179).
2155 The following code works around these bugs. */
2156
2157 if (tzstring)
2158 {
2159 /* Temporarily set TZ to a value that loads a tz file
2160 and that differs from tzstring. */
2161 char *tz = *newenv;
2162 *newenv = (strcmp (tzstring, set_time_zone_rule_tz1 + 3) == 0
2163 ? set_time_zone_rule_tz2 : set_time_zone_rule_tz1);
2164 tzset ();
2165 *newenv = tz;
2166 }
2167 else
2168 {
2169 /* The implied tzstring is unknown, so temporarily set TZ to
2170 two different values that each load a tz file. */
2171 *to = set_time_zone_rule_tz1;
2172 to[1] = 0;
2173 tzset ();
2174 *to = set_time_zone_rule_tz2;
2175 tzset ();
2176 *to = 0;
2177 }
2178
2179 /* Now TZ has the desired value, and tzset can be invoked safely. */
2180 }
2181
2182 tzset ();
2183 #endif
2184 }
2185 \f
2186 /* Insert NARGS Lisp objects in the array ARGS by calling INSERT_FUNC
2187 (if a type of object is Lisp_Int) or INSERT_FROM_STRING_FUNC (if a
2188 type of object is Lisp_String). INHERIT is passed to
2189 INSERT_FROM_STRING_FUNC as the last argument. */
2190
2191 static void
2192 general_insert_function (void (*insert_func)
2193 (const char *, EMACS_INT),
2194 void (*insert_from_string_func)
2195 (Lisp_Object, EMACS_INT, EMACS_INT,
2196 EMACS_INT, EMACS_INT, int),
2197 int inherit, ptrdiff_t nargs, Lisp_Object *args)
2198 {
2199 ptrdiff_t argnum;
2200 register Lisp_Object val;
2201
2202 for (argnum = 0; argnum < nargs; argnum++)
2203 {
2204 val = args[argnum];
2205 if (CHARACTERP (val))
2206 {
2207 int c = XFASTINT (val);
2208 unsigned char str[MAX_MULTIBYTE_LENGTH];
2209 int len;
2210
2211 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2212 len = CHAR_STRING (c, str);
2213 else
2214 {
2215 str[0] = ASCII_CHAR_P (c) ? c : multibyte_char_to_unibyte (c);
2216 len = 1;
2217 }
2218 (*insert_func) ((char *) str, len);
2219 }
2220 else if (STRINGP (val))
2221 {
2222 (*insert_from_string_func) (val, 0, 0,
2223 SCHARS (val),
2224 SBYTES (val),
2225 inherit);
2226 }
2227 else
2228 wrong_type_argument (Qchar_or_string_p, val);
2229 }
2230 }
2231
2232 void
2233 insert1 (Lisp_Object arg)
2234 {
2235 Finsert (1, &arg);
2236 }
2237
2238
2239 /* Callers passing one argument to Finsert need not gcpro the
2240 argument "array", since the only element of the array will
2241 not be used after calling insert or insert_from_string, so
2242 we don't care if it gets trashed. */
2243
2244 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
2245 doc: /* Insert the arguments, either strings or characters, at point.
2246 Point and before-insertion markers move forward to end up
2247 after the inserted text.
2248 Any other markers at the point of insertion remain before the text.
2249
2250 If the current buffer is multibyte, unibyte strings are converted
2251 to multibyte for insertion (see `string-make-multibyte').
2252 If the current buffer is unibyte, multibyte strings are converted
2253 to unibyte for insertion (see `string-make-unibyte').
2254
2255 When operating on binary data, it may be necessary to preserve the
2256 original bytes of a unibyte string when inserting it into a multibyte
2257 buffer; to accomplish this, apply `string-as-multibyte' to the string
2258 and insert the result.
2259
2260 usage: (insert &rest ARGS) */)
2261 (ptrdiff_t nargs, Lisp_Object *args)
2262 {
2263 general_insert_function (insert, insert_from_string, 0, nargs, args);
2264 return Qnil;
2265 }
2266
2267 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
2268 0, MANY, 0,
2269 doc: /* Insert the arguments at point, inheriting properties from adjoining text.
2270 Point and before-insertion markers move forward to end up
2271 after the inserted text.
2272 Any other markers at the point of insertion remain before the text.
2273
2274 If the current buffer is multibyte, unibyte strings are converted
2275 to multibyte for insertion (see `unibyte-char-to-multibyte').
2276 If the current buffer is unibyte, multibyte strings are converted
2277 to unibyte for insertion.
2278
2279 usage: (insert-and-inherit &rest ARGS) */)
2280 (ptrdiff_t nargs, Lisp_Object *args)
2281 {
2282 general_insert_function (insert_and_inherit, insert_from_string, 1,
2283 nargs, args);
2284 return Qnil;
2285 }
2286
2287 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
2288 doc: /* Insert strings or characters at point, relocating markers after the text.
2289 Point and markers move forward to end up after the inserted text.
2290
2291 If the current buffer is multibyte, unibyte strings are converted
2292 to multibyte for insertion (see `unibyte-char-to-multibyte').
2293 If the current buffer is unibyte, multibyte strings are converted
2294 to unibyte for insertion.
2295
2296 usage: (insert-before-markers &rest ARGS) */)
2297 (ptrdiff_t nargs, Lisp_Object *args)
2298 {
2299 general_insert_function (insert_before_markers,
2300 insert_from_string_before_markers, 0,
2301 nargs, args);
2302 return Qnil;
2303 }
2304
2305 DEFUN ("insert-before-markers-and-inherit", Finsert_and_inherit_before_markers,
2306 Sinsert_and_inherit_before_markers, 0, MANY, 0,
2307 doc: /* Insert text at point, relocating markers and inheriting properties.
2308 Point and markers move forward to end up after the inserted text.
2309
2310 If the current buffer is multibyte, unibyte strings are converted
2311 to multibyte for insertion (see `unibyte-char-to-multibyte').
2312 If the current buffer is unibyte, multibyte strings are converted
2313 to unibyte for insertion.
2314
2315 usage: (insert-before-markers-and-inherit &rest ARGS) */)
2316 (ptrdiff_t nargs, Lisp_Object *args)
2317 {
2318 general_insert_function (insert_before_markers_and_inherit,
2319 insert_from_string_before_markers, 1,
2320 nargs, args);
2321 return Qnil;
2322 }
2323 \f
2324 DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 3, 0,
2325 doc: /* Insert COUNT copies of CHARACTER.
2326 Point, and before-insertion markers, are relocated as in the function `insert'.
2327 The optional third arg INHERIT, if non-nil, says to inherit text properties
2328 from adjoining text, if those properties are sticky. */)
2329 (Lisp_Object character, Lisp_Object count, Lisp_Object inherit)
2330 {
2331 register char *string;
2332 register EMACS_INT stringlen;
2333 register int i;
2334 register EMACS_INT n;
2335 int c, len;
2336 unsigned char str[MAX_MULTIBYTE_LENGTH];
2337
2338 CHECK_CHARACTER (character);
2339 CHECK_NUMBER (count);
2340 c = XFASTINT (character);
2341
2342 if (!NILP (BVAR (current_buffer, enable_multibyte_characters)))
2343 len = CHAR_STRING (c, str);
2344 else
2345 str[0] = c, len = 1;
2346 if (BUF_BYTES_MAX / len < XINT (count))
2347 error ("Maximum buffer size would be exceeded");
2348 n = XINT (count) * len;
2349 if (n <= 0)
2350 return Qnil;
2351 stringlen = min (n, 256 * len);
2352 string = (char *) alloca (stringlen);
2353 for (i = 0; i < stringlen; i++)
2354 string[i] = str[i % len];
2355 while (n >= stringlen)
2356 {
2357 QUIT;
2358 if (!NILP (inherit))
2359 insert_and_inherit (string, stringlen);
2360 else
2361 insert (string, stringlen);
2362 n -= stringlen;
2363 }
2364 if (n > 0)
2365 {
2366 if (!NILP (inherit))
2367 insert_and_inherit (string, n);
2368 else
2369 insert (string, n);
2370 }
2371 return Qnil;
2372 }
2373
2374 DEFUN ("insert-byte", Finsert_byte, Sinsert_byte, 2, 3, 0,
2375 doc: /* Insert COUNT (second arg) copies of BYTE (first arg).
2376 Both arguments are required.
2377 BYTE is a number of the range 0..255.
2378
2379 If BYTE is 128..255 and the current buffer is multibyte, the
2380 corresponding eight-bit character is inserted.
2381
2382 Point, and before-insertion markers, are relocated as in the function `insert'.
2383 The optional third arg INHERIT, if non-nil, says to inherit text properties
2384 from adjoining text, if those properties are sticky. */)
2385 (Lisp_Object byte, Lisp_Object count, Lisp_Object inherit)
2386 {
2387 CHECK_NUMBER (byte);
2388 if (XINT (byte) < 0 || XINT (byte) > 255)
2389 args_out_of_range_3 (byte, make_number (0), make_number (255));
2390 if (XINT (byte) >= 128
2391 && ! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2392 XSETFASTINT (byte, BYTE8_TO_CHAR (XINT (byte)));
2393 return Finsert_char (byte, count, inherit);
2394 }
2395
2396 \f
2397 /* Making strings from buffer contents. */
2398
2399 /* Return a Lisp_String containing the text of the current buffer from
2400 START to END. If text properties are in use and the current buffer
2401 has properties in the range specified, the resulting string will also
2402 have them, if PROPS is nonzero.
2403
2404 We don't want to use plain old make_string here, because it calls
2405 make_uninit_string, which can cause the buffer arena to be
2406 compacted. make_string has no way of knowing that the data has
2407 been moved, and thus copies the wrong data into the string. This
2408 doesn't effect most of the other users of make_string, so it should
2409 be left as is. But we should use this function when conjuring
2410 buffer substrings. */
2411
2412 Lisp_Object
2413 make_buffer_string (EMACS_INT start, EMACS_INT end, int props)
2414 {
2415 EMACS_INT start_byte = CHAR_TO_BYTE (start);
2416 EMACS_INT end_byte = CHAR_TO_BYTE (end);
2417
2418 return make_buffer_string_both (start, start_byte, end, end_byte, props);
2419 }
2420
2421 /* Return a Lisp_String containing the text of the current buffer from
2422 START / START_BYTE to END / END_BYTE.
2423
2424 If text properties are in use and the current buffer
2425 has properties in the range specified, the resulting string will also
2426 have them, if PROPS is nonzero.
2427
2428 We don't want to use plain old make_string here, because it calls
2429 make_uninit_string, which can cause the buffer arena to be
2430 compacted. make_string has no way of knowing that the data has
2431 been moved, and thus copies the wrong data into the string. This
2432 doesn't effect most of the other users of make_string, so it should
2433 be left as is. But we should use this function when conjuring
2434 buffer substrings. */
2435
2436 Lisp_Object
2437 make_buffer_string_both (EMACS_INT start, EMACS_INT start_byte,
2438 EMACS_INT end, EMACS_INT end_byte, int props)
2439 {
2440 Lisp_Object result, tem, tem1;
2441
2442 if (start < GPT && GPT < end)
2443 move_gap (start);
2444
2445 if (! NILP (BVAR (current_buffer, enable_multibyte_characters)))
2446 result = make_uninit_multibyte_string (end - start, end_byte - start_byte);
2447 else
2448 result = make_uninit_string (end - start);
2449 memcpy (SDATA (result), BYTE_POS_ADDR (start_byte), end_byte - start_byte);
2450
2451 /* If desired, update and copy the text properties. */
2452 if (props)
2453 {
2454 update_buffer_properties (start, end);
2455
2456 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
2457 tem1 = Ftext_properties_at (make_number (start), Qnil);
2458
2459 if (XINT (tem) != end || !NILP (tem1))
2460 copy_intervals_to_string (result, current_buffer, start,
2461 end - start);
2462 }
2463
2464 return result;
2465 }
2466
2467 /* Call Vbuffer_access_fontify_functions for the range START ... END
2468 in the current buffer, if necessary. */
2469
2470 static void
2471 update_buffer_properties (EMACS_INT start, EMACS_INT end)
2472 {
2473 /* If this buffer has some access functions,
2474 call them, specifying the range of the buffer being accessed. */
2475 if (!NILP (Vbuffer_access_fontify_functions))
2476 {
2477 Lisp_Object args[3];
2478 Lisp_Object tem;
2479
2480 args[0] = Qbuffer_access_fontify_functions;
2481 XSETINT (args[1], start);
2482 XSETINT (args[2], end);
2483
2484 /* But don't call them if we can tell that the work
2485 has already been done. */
2486 if (!NILP (Vbuffer_access_fontified_property))
2487 {
2488 tem = Ftext_property_any (args[1], args[2],
2489 Vbuffer_access_fontified_property,
2490 Qnil, Qnil);
2491 if (! NILP (tem))
2492 Frun_hook_with_args (3, args);
2493 }
2494 else
2495 Frun_hook_with_args (3, args);
2496 }
2497 }
2498
2499 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
2500 doc: /* Return the contents of part of the current buffer as a string.
2501 The two arguments START and END are character positions;
2502 they can be in either order.
2503 The string returned is multibyte if the buffer is multibyte.
2504
2505 This function copies the text properties of that part of the buffer
2506 into the result string; if you don't want the text properties,
2507 use `buffer-substring-no-properties' instead. */)
2508 (Lisp_Object start, Lisp_Object end)
2509 {
2510 register EMACS_INT b, e;
2511
2512 validate_region (&start, &end);
2513 b = XINT (start);
2514 e = XINT (end);
2515
2516 return make_buffer_string (b, e, 1);
2517 }
2518
2519 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
2520 Sbuffer_substring_no_properties, 2, 2, 0,
2521 doc: /* Return the characters of part of the buffer, without the text properties.
2522 The two arguments START and END are character positions;
2523 they can be in either order. */)
2524 (Lisp_Object start, Lisp_Object end)
2525 {
2526 register EMACS_INT b, e;
2527
2528 validate_region (&start, &end);
2529 b = XINT (start);
2530 e = XINT (end);
2531
2532 return make_buffer_string (b, e, 0);
2533 }
2534
2535 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
2536 doc: /* Return the contents of the current buffer as a string.
2537 If narrowing is in effect, this function returns only the visible part
2538 of the buffer. */)
2539 (void)
2540 {
2541 return make_buffer_string (BEGV, ZV, 1);
2542 }
2543
2544 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
2545 1, 3, 0,
2546 doc: /* Insert before point a substring of the contents of BUFFER.
2547 BUFFER may be a buffer or a buffer name.
2548 Arguments START and END are character positions specifying the substring.
2549 They default to the values of (point-min) and (point-max) in BUFFER. */)
2550 (Lisp_Object buffer, Lisp_Object start, Lisp_Object end)
2551 {
2552 register EMACS_INT b, e, temp;
2553 register struct buffer *bp, *obuf;
2554 Lisp_Object buf;
2555
2556 buf = Fget_buffer (buffer);
2557 if (NILP (buf))
2558 nsberror (buffer);
2559 bp = XBUFFER (buf);
2560 if (NILP (BVAR (bp, name)))
2561 error ("Selecting deleted buffer");
2562
2563 if (NILP (start))
2564 b = BUF_BEGV (bp);
2565 else
2566 {
2567 CHECK_NUMBER_COERCE_MARKER (start);
2568 b = XINT (start);
2569 }
2570 if (NILP (end))
2571 e = BUF_ZV (bp);
2572 else
2573 {
2574 CHECK_NUMBER_COERCE_MARKER (end);
2575 e = XINT (end);
2576 }
2577
2578 if (b > e)
2579 temp = b, b = e, e = temp;
2580
2581 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
2582 args_out_of_range (start, end);
2583
2584 obuf = current_buffer;
2585 set_buffer_internal_1 (bp);
2586 update_buffer_properties (b, e);
2587 set_buffer_internal_1 (obuf);
2588
2589 insert_from_buffer (bp, b, e - b, 0);
2590 return Qnil;
2591 }
2592
2593 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
2594 6, 6, 0,
2595 doc: /* Compare two substrings of two buffers; return result as number.
2596 the value is -N if first string is less after N-1 chars,
2597 +N if first string is greater after N-1 chars, or 0 if strings match.
2598 Each substring is represented as three arguments: BUFFER, START and END.
2599 That makes six args in all, three for each substring.
2600
2601 The value of `case-fold-search' in the current buffer
2602 determines whether case is significant or ignored. */)
2603 (Lisp_Object buffer1, Lisp_Object start1, Lisp_Object end1, Lisp_Object buffer2, Lisp_Object start2, Lisp_Object end2)
2604 {
2605 register EMACS_INT begp1, endp1, begp2, endp2, temp;
2606 register struct buffer *bp1, *bp2;
2607 register Lisp_Object trt
2608 = (!NILP (BVAR (current_buffer, case_fold_search))
2609 ? BVAR (current_buffer, case_canon_table) : Qnil);
2610 EMACS_INT chars = 0;
2611 EMACS_INT i1, i2, i1_byte, i2_byte;
2612
2613 /* Find the first buffer and its substring. */
2614
2615 if (NILP (buffer1))
2616 bp1 = current_buffer;
2617 else
2618 {
2619 Lisp_Object buf1;
2620 buf1 = Fget_buffer (buffer1);
2621 if (NILP (buf1))
2622 nsberror (buffer1);
2623 bp1 = XBUFFER (buf1);
2624 if (NILP (BVAR (bp1, name)))
2625 error ("Selecting deleted buffer");
2626 }
2627
2628 if (NILP (start1))
2629 begp1 = BUF_BEGV (bp1);
2630 else
2631 {
2632 CHECK_NUMBER_COERCE_MARKER (start1);
2633 begp1 = XINT (start1);
2634 }
2635 if (NILP (end1))
2636 endp1 = BUF_ZV (bp1);
2637 else
2638 {
2639 CHECK_NUMBER_COERCE_MARKER (end1);
2640 endp1 = XINT (end1);
2641 }
2642
2643 if (begp1 > endp1)
2644 temp = begp1, begp1 = endp1, endp1 = temp;
2645
2646 if (!(BUF_BEGV (bp1) <= begp1
2647 && begp1 <= endp1
2648 && endp1 <= BUF_ZV (bp1)))
2649 args_out_of_range (start1, end1);
2650
2651 /* Likewise for second substring. */
2652
2653 if (NILP (buffer2))
2654 bp2 = current_buffer;
2655 else
2656 {
2657 Lisp_Object buf2;
2658 buf2 = Fget_buffer (buffer2);
2659 if (NILP (buf2))
2660 nsberror (buffer2);
2661 bp2 = XBUFFER (buf2);
2662 if (NILP (BVAR (bp2, name)))
2663 error ("Selecting deleted buffer");
2664 }
2665
2666 if (NILP (start2))
2667 begp2 = BUF_BEGV (bp2);
2668 else
2669 {
2670 CHECK_NUMBER_COERCE_MARKER (start2);
2671 begp2 = XINT (start2);
2672 }
2673 if (NILP (end2))
2674 endp2 = BUF_ZV (bp2);
2675 else
2676 {
2677 CHECK_NUMBER_COERCE_MARKER (end2);
2678 endp2 = XINT (end2);
2679 }
2680
2681 if (begp2 > endp2)
2682 temp = begp2, begp2 = endp2, endp2 = temp;
2683
2684 if (!(BUF_BEGV (bp2) <= begp2
2685 && begp2 <= endp2
2686 && endp2 <= BUF_ZV (bp2)))
2687 args_out_of_range (start2, end2);
2688
2689 i1 = begp1;
2690 i2 = begp2;
2691 i1_byte = buf_charpos_to_bytepos (bp1, i1);
2692 i2_byte = buf_charpos_to_bytepos (bp2, i2);
2693
2694 while (i1 < endp1 && i2 < endp2)
2695 {
2696 /* When we find a mismatch, we must compare the
2697 characters, not just the bytes. */
2698 int c1, c2;
2699
2700 QUIT;
2701
2702 if (! NILP (BVAR (bp1, enable_multibyte_characters)))
2703 {
2704 c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte);
2705 BUF_INC_POS (bp1, i1_byte);
2706 i1++;
2707 }
2708 else
2709 {
2710 c1 = BUF_FETCH_BYTE (bp1, i1);
2711 MAKE_CHAR_MULTIBYTE (c1);
2712 i1++;
2713 }
2714
2715 if (! NILP (BVAR (bp2, enable_multibyte_characters)))
2716 {
2717 c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte);
2718 BUF_INC_POS (bp2, i2_byte);
2719 i2++;
2720 }
2721 else
2722 {
2723 c2 = BUF_FETCH_BYTE (bp2, i2);
2724 MAKE_CHAR_MULTIBYTE (c2);
2725 i2++;
2726 }
2727
2728 if (!NILP (trt))
2729 {
2730 c1 = CHAR_TABLE_TRANSLATE (trt, c1);
2731 c2 = CHAR_TABLE_TRANSLATE (trt, c2);
2732 }
2733 if (c1 < c2)
2734 return make_number (- 1 - chars);
2735 if (c1 > c2)
2736 return make_number (chars + 1);
2737
2738 chars++;
2739 }
2740
2741 /* The strings match as far as they go.
2742 If one is shorter, that one is less. */
2743 if (chars < endp1 - begp1)
2744 return make_number (chars + 1);
2745 else if (chars < endp2 - begp2)
2746 return make_number (- chars - 1);
2747
2748 /* Same length too => they are equal. */
2749 return make_number (0);
2750 }
2751 \f
2752 static Lisp_Object
2753 subst_char_in_region_unwind (Lisp_Object arg)
2754 {
2755 return BVAR (current_buffer, undo_list) = arg;
2756 }
2757
2758 static Lisp_Object
2759 subst_char_in_region_unwind_1 (Lisp_Object arg)
2760 {
2761 return BVAR (current_buffer, filename) = arg;
2762 }
2763
2764 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
2765 Ssubst_char_in_region, 4, 5, 0,
2766 doc: /* From START to END, replace FROMCHAR with TOCHAR each time it occurs.
2767 If optional arg NOUNDO is non-nil, don't record this change for undo
2768 and don't mark the buffer as really changed.
2769 Both characters must have the same length of multi-byte form. */)
2770 (Lisp_Object start, Lisp_Object end, Lisp_Object fromchar, Lisp_Object tochar, Lisp_Object noundo)
2771 {
2772 register EMACS_INT pos, pos_byte, stop, i, len, end_byte;
2773 /* Keep track of the first change in the buffer:
2774 if 0 we haven't found it yet.
2775 if < 0 we've found it and we've run the before-change-function.
2776 if > 0 we've actually performed it and the value is its position. */
2777 EMACS_INT changed = 0;
2778 unsigned char fromstr[MAX_MULTIBYTE_LENGTH], tostr[MAX_MULTIBYTE_LENGTH];
2779 unsigned char *p;
2780 int count = SPECPDL_INDEX ();
2781 #define COMBINING_NO 0
2782 #define COMBINING_BEFORE 1
2783 #define COMBINING_AFTER 2
2784 #define COMBINING_BOTH (COMBINING_BEFORE | COMBINING_AFTER)
2785 int maybe_byte_combining = COMBINING_NO;
2786 EMACS_INT last_changed = 0;
2787 int multibyte_p = !NILP (BVAR (current_buffer, enable_multibyte_characters));
2788 int fromc, toc;
2789
2790 restart:
2791
2792 validate_region (&start, &end);
2793 CHECK_CHARACTER (fromchar);
2794 CHECK_CHARACTER (tochar);
2795 fromc = XFASTINT (fromchar);
2796 toc = XFASTINT (tochar);
2797
2798 if (multibyte_p)
2799 {
2800 len = CHAR_STRING (fromc, fromstr);
2801 if (CHAR_STRING (toc, tostr) != len)
2802 error ("Characters in `subst-char-in-region' have different byte-lengths");
2803 if (!ASCII_BYTE_P (*tostr))
2804 {
2805 /* If *TOSTR is in the range 0x80..0x9F and TOCHAR is not a
2806 complete multibyte character, it may be combined with the
2807 after bytes. If it is in the range 0xA0..0xFF, it may be
2808 combined with the before and after bytes. */
2809 if (!CHAR_HEAD_P (*tostr))
2810 maybe_byte_combining = COMBINING_BOTH;
2811 else if (BYTES_BY_CHAR_HEAD (*tostr) > len)
2812 maybe_byte_combining = COMBINING_AFTER;
2813 }
2814 }
2815 else
2816 {
2817 len = 1;
2818 fromstr[0] = fromc;
2819 tostr[0] = toc;
2820 }
2821
2822 pos = XINT (start);
2823 pos_byte = CHAR_TO_BYTE (pos);
2824 stop = CHAR_TO_BYTE (XINT (end));
2825 end_byte = stop;
2826
2827 /* If we don't want undo, turn off putting stuff on the list.
2828 That's faster than getting rid of things,
2829 and it prevents even the entry for a first change.
2830 Also inhibit locking the file. */
2831 if (!changed && !NILP (noundo))
2832 {
2833 record_unwind_protect (subst_char_in_region_unwind,
2834 BVAR (current_buffer, undo_list));
2835 BVAR (current_buffer, undo_list) = Qt;
2836 /* Don't do file-locking. */
2837 record_unwind_protect (subst_char_in_region_unwind_1,
2838 BVAR (current_buffer, filename));
2839 BVAR (current_buffer, filename) = Qnil;
2840 }
2841
2842 if (pos_byte < GPT_BYTE)
2843 stop = min (stop, GPT_BYTE);
2844 while (1)
2845 {
2846 EMACS_INT pos_byte_next = pos_byte;
2847
2848 if (pos_byte >= stop)
2849 {
2850 if (pos_byte >= end_byte) break;
2851 stop = end_byte;
2852 }
2853 p = BYTE_POS_ADDR (pos_byte);
2854 if (multibyte_p)
2855 INC_POS (pos_byte_next);
2856 else
2857 ++pos_byte_next;
2858 if (pos_byte_next - pos_byte == len
2859 && p[0] == fromstr[0]
2860 && (len == 1
2861 || (p[1] == fromstr[1]
2862 && (len == 2 || (p[2] == fromstr[2]
2863 && (len == 3 || p[3] == fromstr[3]))))))
2864 {
2865 if (changed < 0)
2866 /* We've already seen this and run the before-change-function;
2867 this time we only need to record the actual position. */
2868 changed = pos;
2869 else if (!changed)
2870 {
2871 changed = -1;
2872 modify_region (current_buffer, pos, XINT (end), 0);
2873
2874 if (! NILP (noundo))
2875 {
2876 if (MODIFF - 1 == SAVE_MODIFF)
2877 SAVE_MODIFF++;
2878 if (MODIFF - 1 == BUF_AUTOSAVE_MODIFF (current_buffer))
2879 BUF_AUTOSAVE_MODIFF (current_buffer)++;
2880 }
2881
2882 /* The before-change-function may have moved the gap
2883 or even modified the buffer so we should start over. */
2884 goto restart;
2885 }
2886
2887 /* Take care of the case where the new character
2888 combines with neighboring bytes. */
2889 if (maybe_byte_combining
2890 && (maybe_byte_combining == COMBINING_AFTER
2891 ? (pos_byte_next < Z_BYTE
2892 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2893 : ((pos_byte_next < Z_BYTE
2894 && ! CHAR_HEAD_P (FETCH_BYTE (pos_byte_next)))
2895 || (pos_byte > BEG_BYTE
2896 && ! ASCII_BYTE_P (FETCH_BYTE (pos_byte - 1))))))
2897 {
2898 Lisp_Object tem, string;
2899
2900 struct gcpro gcpro1;
2901
2902 tem = BVAR (current_buffer, undo_list);
2903 GCPRO1 (tem);
2904
2905 /* Make a multibyte string containing this single character. */
2906 string = make_multibyte_string ((char *) tostr, 1, len);
2907 /* replace_range is less efficient, because it moves the gap,
2908 but it handles combining correctly. */
2909 replace_range (pos, pos + 1, string,
2910 0, 0, 1);
2911 pos_byte_next = CHAR_TO_BYTE (pos);
2912 if (pos_byte_next > pos_byte)
2913 /* Before combining happened. We should not increment
2914 POS. So, to cancel the later increment of POS,
2915 decrease it now. */
2916 pos--;
2917 else
2918 INC_POS (pos_byte_next);
2919
2920 if (! NILP (noundo))
2921 BVAR (current_buffer, undo_list) = tem;
2922
2923 UNGCPRO;
2924 }
2925 else
2926 {
2927 if (NILP (noundo))
2928 record_change (pos, 1);
2929 for (i = 0; i < len; i++) *p++ = tostr[i];
2930 }
2931 last_changed = pos + 1;
2932 }
2933 pos_byte = pos_byte_next;
2934 pos++;
2935 }
2936
2937 if (changed > 0)
2938 {
2939 signal_after_change (changed,
2940 last_changed - changed, last_changed - changed);
2941 update_compositions (changed, last_changed, CHECK_ALL);
2942 }
2943
2944 unbind_to (count, Qnil);
2945 return Qnil;
2946 }
2947
2948
2949 static Lisp_Object check_translation (EMACS_INT, EMACS_INT, EMACS_INT,
2950 Lisp_Object);
2951
2952 /* Helper function for Ftranslate_region_internal.
2953
2954 Check if a character sequence at POS (POS_BYTE) matches an element
2955 of VAL. VAL is a list (([FROM-CHAR ...] . TO) ...). If a matching
2956 element is found, return it. Otherwise return Qnil. */
2957
2958 static Lisp_Object
2959 check_translation (EMACS_INT pos, EMACS_INT pos_byte, EMACS_INT end,
2960 Lisp_Object val)
2961 {
2962 int buf_size = 16, buf_used = 0;
2963 int *buf = alloca (sizeof (int) * buf_size);
2964
2965 for (; CONSP (val); val = XCDR (val))
2966 {
2967 Lisp_Object elt;
2968 EMACS_INT len, i;
2969
2970 elt = XCAR (val);
2971 if (! CONSP (elt))
2972 continue;
2973 elt = XCAR (elt);
2974 if (! VECTORP (elt))
2975 continue;
2976 len = ASIZE (elt);
2977 if (len <= end - pos)
2978 {
2979 for (i = 0; i < len; i++)
2980 {
2981 if (buf_used <= i)
2982 {
2983 unsigned char *p = BYTE_POS_ADDR (pos_byte);
2984 int len1;
2985
2986 if (buf_used == buf_size)
2987 {
2988 int *newbuf;
2989
2990 buf_size += 16;
2991 newbuf = alloca (sizeof (int) * buf_size);
2992 memcpy (newbuf, buf, sizeof (int) * buf_used);
2993 buf = newbuf;
2994 }
2995 buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1);
2996 pos_byte += len1;
2997 }
2998 if (XINT (AREF (elt, i)) != buf[i])
2999 break;
3000 }
3001 if (i == len)
3002 return XCAR (val);
3003 }
3004 }
3005 return Qnil;
3006 }
3007
3008
3009 DEFUN ("translate-region-internal", Ftranslate_region_internal,
3010 Stranslate_region_internal, 3, 3, 0,
3011 doc: /* Internal use only.
3012 From START to END, translate characters according to TABLE.
3013 TABLE is a string or a char-table; the Nth character in it is the
3014 mapping for the character with code N.
3015 It returns the number of characters changed. */)
3016 (Lisp_Object start, Lisp_Object end, register Lisp_Object table)
3017 {
3018 register unsigned char *tt; /* Trans table. */
3019 register int nc; /* New character. */
3020 int cnt; /* Number of changes made. */
3021 EMACS_INT size; /* Size of translate table. */
3022 EMACS_INT pos, pos_byte, end_pos;
3023 int multibyte = !NILP (BVAR (current_buffer, enable_multibyte_characters));
3024 int string_multibyte IF_LINT (= 0);
3025
3026 validate_region (&start, &end);
3027 if (CHAR_TABLE_P (table))
3028 {
3029 if (! EQ (XCHAR_TABLE (table)->purpose, Qtranslation_table))
3030 error ("Not a translation table");
3031 size = MAX_CHAR;
3032 tt = NULL;
3033 }
3034 else
3035 {
3036 CHECK_STRING (table);
3037
3038 if (! multibyte && (SCHARS (table) < SBYTES (table)))
3039 table = string_make_unibyte (table);
3040 string_multibyte = SCHARS (table) < SBYTES (table);
3041 size = SBYTES (table);
3042 tt = SDATA (table);
3043 }
3044
3045 pos = XINT (start);
3046 pos_byte = CHAR_TO_BYTE (pos);
3047 end_pos = XINT (end);
3048 modify_region (current_buffer, pos, end_pos, 0);
3049
3050 cnt = 0;
3051 for (; pos < end_pos; )
3052 {
3053 register unsigned char *p = BYTE_POS_ADDR (pos_byte);
3054 unsigned char *str, buf[MAX_MULTIBYTE_LENGTH];
3055 int len, str_len;
3056 int oc;
3057 Lisp_Object val;
3058
3059 if (multibyte)
3060 oc = STRING_CHAR_AND_LENGTH (p, len);
3061 else
3062 oc = *p, len = 1;
3063 if (oc < size)
3064 {
3065 if (tt)
3066 {
3067 /* Reload as signal_after_change in last iteration may GC. */
3068 tt = SDATA (table);
3069 if (string_multibyte)
3070 {
3071 str = tt + string_char_to_byte (table, oc);
3072 nc = STRING_CHAR_AND_LENGTH (str, str_len);
3073 }
3074 else
3075 {
3076 nc = tt[oc];
3077 if (! ASCII_BYTE_P (nc) && multibyte)
3078 {
3079 str_len = BYTE8_STRING (nc, buf);
3080 str = buf;
3081 }
3082 else
3083 {
3084 str_len = 1;
3085 str = tt + oc;
3086 }
3087 }
3088 }
3089 else
3090 {
3091 nc = oc;
3092 val = CHAR_TABLE_REF (table, oc);
3093 if (CHARACTERP (val))
3094 {
3095 nc = XFASTINT (val);
3096 str_len = CHAR_STRING (nc, buf);
3097 str = buf;
3098 }
3099 else if (VECTORP (val) || (CONSP (val)))
3100 {
3101 /* VAL is [TO_CHAR ...] or (([FROM-CHAR ...] . TO) ...)
3102 where TO is TO-CHAR or [TO-CHAR ...]. */
3103 nc = -1;
3104 }
3105 }
3106
3107 if (nc != oc && nc >= 0)
3108 {
3109 /* Simple one char to one char translation. */
3110 if (len != str_len)
3111 {
3112 Lisp_Object string;
3113
3114 /* This is less efficient, because it moves the gap,
3115 but it should handle multibyte characters correctly. */
3116 string = make_multibyte_string ((char *) str, 1, str_len);
3117 replace_range (pos, pos + 1, string, 1, 0, 1);
3118 len = str_len;
3119 }
3120 else
3121 {
3122 record_change (pos, 1);
3123 while (str_len-- > 0)
3124 *p++ = *str++;
3125 signal_after_change (pos, 1, 1);
3126 update_compositions (pos, pos + 1, CHECK_BORDER);
3127 }
3128 ++cnt;
3129 }
3130 else if (nc < 0)
3131 {
3132 Lisp_Object string;
3133
3134 if (CONSP (val))
3135 {
3136 val = check_translation (pos, pos_byte, end_pos, val);
3137 if (NILP (val))
3138 {
3139 pos_byte += len;
3140 pos++;
3141 continue;
3142 }
3143 /* VAL is ([FROM-CHAR ...] . TO). */
3144 len = ASIZE (XCAR (val));
3145 val = XCDR (val);
3146 }
3147 else
3148 len = 1;
3149
3150 if (VECTORP (val))
3151 {
3152 string = Fconcat (1, &val);
3153 }
3154 else
3155 {
3156 string = Fmake_string (make_number (1), val);
3157 }
3158 replace_range (pos, pos + len, string, 1, 0, 1);
3159 pos_byte += SBYTES (string);
3160 pos += SCHARS (string);
3161 cnt += SCHARS (string);
3162 end_pos += SCHARS (string) - len;
3163 continue;
3164 }
3165 }
3166 pos_byte += len;
3167 pos++;
3168 }
3169
3170 return make_number (cnt);
3171 }
3172
3173 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
3174 doc: /* Delete the text between point and mark.
3175
3176 When called from a program, expects two arguments,
3177 positions (integers or markers) specifying the stretch to be deleted. */)
3178 (Lisp_Object start, Lisp_Object end)
3179 {
3180 validate_region (&start, &end);
3181 del_range (XINT (start), XINT (end));
3182 return Qnil;
3183 }
3184
3185 DEFUN ("delete-and-extract-region", Fdelete_and_extract_region,
3186 Sdelete_and_extract_region, 2, 2, 0,
3187 doc: /* Delete the text between START and END and return it. */)
3188 (Lisp_Object start, Lisp_Object end)
3189 {
3190 validate_region (&start, &end);
3191 if (XINT (start) == XINT (end))
3192 return empty_unibyte_string;
3193 return del_range_1 (XINT (start), XINT (end), 1, 1);
3194 }
3195 \f
3196 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
3197 doc: /* Remove restrictions (narrowing) from current buffer.
3198 This allows the buffer's full text to be seen and edited. */)
3199 (void)
3200 {
3201 if (BEG != BEGV || Z != ZV)
3202 current_buffer->clip_changed = 1;
3203 BEGV = BEG;
3204 BEGV_BYTE = BEG_BYTE;
3205 SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE);
3206 /* Changing the buffer bounds invalidates any recorded current column. */
3207 invalidate_current_column ();
3208 return Qnil;
3209 }
3210
3211 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
3212 doc: /* Restrict editing in this buffer to the current region.
3213 The rest of the text becomes temporarily invisible and untouchable
3214 but is not deleted; if you save the buffer in a file, the invisible
3215 text is included in the file. \\[widen] makes all visible again.
3216 See also `save-restriction'.
3217
3218 When calling from a program, pass two arguments; positions (integers
3219 or markers) bounding the text that should remain visible. */)
3220 (register Lisp_Object start, Lisp_Object end)
3221 {
3222 CHECK_NUMBER_COERCE_MARKER (start);
3223 CHECK_NUMBER_COERCE_MARKER (end);
3224
3225 if (XINT (start) > XINT (end))
3226 {
3227 Lisp_Object tem;
3228 tem = start; start = end; end = tem;
3229 }
3230
3231 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
3232 args_out_of_range (start, end);
3233
3234 if (BEGV != XFASTINT (start) || ZV != XFASTINT (end))
3235 current_buffer->clip_changed = 1;
3236
3237 SET_BUF_BEGV (current_buffer, XFASTINT (start));
3238 SET_BUF_ZV (current_buffer, XFASTINT (end));
3239 if (PT < XFASTINT (start))
3240 SET_PT (XFASTINT (start));
3241 if (PT > XFASTINT (end))
3242 SET_PT (XFASTINT (end));
3243 /* Changing the buffer bounds invalidates any recorded current column. */
3244 invalidate_current_column ();
3245 return Qnil;
3246 }
3247
3248 Lisp_Object
3249 save_restriction_save (void)
3250 {
3251 if (BEGV == BEG && ZV == Z)
3252 /* The common case that the buffer isn't narrowed.
3253 We return just the buffer object, which save_restriction_restore
3254 recognizes as meaning `no restriction'. */
3255 return Fcurrent_buffer ();
3256 else
3257 /* We have to save a restriction, so return a pair of markers, one
3258 for the beginning and one for the end. */
3259 {
3260 Lisp_Object beg, end;
3261
3262 beg = buildmark (BEGV, BEGV_BYTE);
3263 end = buildmark (ZV, ZV_BYTE);
3264
3265 /* END must move forward if text is inserted at its exact location. */
3266 XMARKER(end)->insertion_type = 1;
3267
3268 return Fcons (beg, end);
3269 }
3270 }
3271
3272 Lisp_Object
3273 save_restriction_restore (Lisp_Object data)
3274 {
3275 struct buffer *cur = NULL;
3276 struct buffer *buf = (CONSP (data)
3277 ? XMARKER (XCAR (data))->buffer
3278 : XBUFFER (data));
3279
3280 if (buf && buf != current_buffer && !NILP (BVAR (buf, pt_marker)))
3281 { /* If `buf' uses markers to keep track of PT, BEGV, and ZV (as
3282 is the case if it is or has an indirect buffer), then make
3283 sure it is current before we update BEGV, so
3284 set_buffer_internal takes care of managing those markers. */
3285 cur = current_buffer;
3286 set_buffer_internal (buf);
3287 }
3288
3289 if (CONSP (data))
3290 /* A pair of marks bounding a saved restriction. */
3291 {
3292 struct Lisp_Marker *beg = XMARKER (XCAR (data));
3293 struct Lisp_Marker *end = XMARKER (XCDR (data));
3294 eassert (buf == end->buffer);
3295
3296 if (buf /* Verify marker still points to a buffer. */
3297 && (beg->charpos != BUF_BEGV (buf) || end->charpos != BUF_ZV (buf)))
3298 /* The restriction has changed from the saved one, so restore
3299 the saved restriction. */
3300 {
3301 EMACS_INT pt = BUF_PT (buf);
3302
3303 SET_BUF_BEGV_BOTH (buf, beg->charpos, beg->bytepos);
3304 SET_BUF_ZV_BOTH (buf, end->charpos, end->bytepos);
3305
3306 if (pt < beg->charpos || pt > end->charpos)
3307 /* The point is outside the new visible range, move it inside. */
3308 SET_BUF_PT_BOTH (buf,
3309 clip_to_bounds (beg->charpos, pt, end->charpos),
3310 clip_to_bounds (beg->bytepos, BUF_PT_BYTE (buf),
3311 end->bytepos));
3312
3313 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3314 }
3315 }
3316 else
3317 /* A buffer, which means that there was no old restriction. */
3318 {
3319 if (buf /* Verify marker still points to a buffer. */
3320 && (BUF_BEGV (buf) != BUF_BEG (buf) || BUF_ZV (buf) != BUF_Z (buf)))
3321 /* The buffer has been narrowed, get rid of the narrowing. */
3322 {
3323 SET_BUF_BEGV_BOTH (buf, BUF_BEG (buf), BUF_BEG_BYTE (buf));
3324 SET_BUF_ZV_BOTH (buf, BUF_Z (buf), BUF_Z_BYTE (buf));
3325
3326 buf->clip_changed = 1; /* Remember that the narrowing changed. */
3327 }
3328 }
3329
3330 /* Changing the buffer bounds invalidates any recorded current column. */
3331 invalidate_current_column ();
3332
3333 if (cur)
3334 set_buffer_internal (cur);
3335
3336 return Qnil;
3337 }
3338
3339 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
3340 doc: /* Execute BODY, saving and restoring current buffer's restrictions.
3341 The buffer's restrictions make parts of the beginning and end invisible.
3342 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
3343 This special form, `save-restriction', saves the current buffer's restrictions
3344 when it is entered, and restores them when it is exited.
3345 So any `narrow-to-region' within BODY lasts only until the end of the form.
3346 The old restrictions settings are restored
3347 even in case of abnormal exit (throw or error).
3348
3349 The value returned is the value of the last form in BODY.
3350
3351 Note: if you are using both `save-excursion' and `save-restriction',
3352 use `save-excursion' outermost:
3353 (save-excursion (save-restriction ...))
3354
3355 usage: (save-restriction &rest BODY) */)
3356 (Lisp_Object body)
3357 {
3358 register Lisp_Object val;
3359 int count = SPECPDL_INDEX ();
3360
3361 record_unwind_protect (save_restriction_restore, save_restriction_save ());
3362 val = Fprogn (body);
3363 return unbind_to (count, val);
3364 }
3365 \f
3366 /* Buffer for the most recent text displayed by Fmessage_box. */
3367 static char *message_text;
3368
3369 /* Allocated length of that buffer. */
3370 static int message_length;
3371
3372 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
3373 doc: /* Display a message at the bottom of the screen.
3374 The message also goes into the `*Messages*' buffer.
3375 \(In keyboard macros, that's all it does.)
3376 Return the message.
3377
3378 The first argument is a format control string, and the rest are data
3379 to be formatted under control of the string. See `format' for details.
3380
3381 Note: Use (message "%s" VALUE) to print the value of expressions and
3382 variables to avoid accidentally interpreting `%' as format specifiers.
3383
3384 If the first argument is nil or the empty string, the function clears
3385 any existing message; this lets the minibuffer contents show. See
3386 also `current-message'.
3387
3388 usage: (message FORMAT-STRING &rest ARGS) */)
3389 (ptrdiff_t nargs, Lisp_Object *args)
3390 {
3391 if (NILP (args[0])
3392 || (STRINGP (args[0])
3393 && SBYTES (args[0]) == 0))
3394 {
3395 message (0);
3396 return args[0];
3397 }
3398 else
3399 {
3400 register Lisp_Object val;
3401 val = Fformat (nargs, args);
3402 message3 (val, SBYTES (val), STRING_MULTIBYTE (val));
3403 return val;
3404 }
3405 }
3406
3407 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
3408 doc: /* Display a message, in a dialog box if possible.
3409 If a dialog box is not available, use the echo area.
3410 The first argument is a format control string, and the rest are data
3411 to be formatted under control of the string. See `format' for details.
3412
3413 If the first argument is nil or the empty string, clear any existing
3414 message; let the minibuffer contents show.
3415
3416 usage: (message-box FORMAT-STRING &rest ARGS) */)
3417 (ptrdiff_t nargs, Lisp_Object *args)
3418 {
3419 if (NILP (args[0]))
3420 {
3421 message (0);
3422 return Qnil;
3423 }
3424 else
3425 {
3426 register Lisp_Object val;
3427 val = Fformat (nargs, args);
3428 #ifdef HAVE_MENUS
3429 /* The MS-DOS frames support popup menus even though they are
3430 not FRAME_WINDOW_P. */
3431 if (FRAME_WINDOW_P (XFRAME (selected_frame))
3432 || FRAME_MSDOS_P (XFRAME (selected_frame)))
3433 {
3434 Lisp_Object pane, menu;
3435 struct gcpro gcpro1;
3436 pane = Fcons (Fcons (build_string ("OK"), Qt), Qnil);
3437 GCPRO1 (pane);
3438 menu = Fcons (val, pane);
3439 Fx_popup_dialog (Qt, menu, Qt);
3440 UNGCPRO;
3441 return val;
3442 }
3443 #endif /* HAVE_MENUS */
3444 /* Copy the data so that it won't move when we GC. */
3445 if (! message_text)
3446 {
3447 message_text = (char *)xmalloc (80);
3448 message_length = 80;
3449 }
3450 if (SBYTES (val) > message_length)
3451 {
3452 message_length = SBYTES (val);
3453 message_text = (char *)xrealloc (message_text, message_length);
3454 }
3455 memcpy (message_text, SDATA (val), SBYTES (val));
3456 message2 (message_text, SBYTES (val),
3457 STRING_MULTIBYTE (val));
3458 return val;
3459 }
3460 }
3461
3462 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
3463 doc: /* Display a message in a dialog box or in the echo area.
3464 If this command was invoked with the mouse, use a dialog box if
3465 `use-dialog-box' is non-nil.
3466 Otherwise, use the echo area.
3467 The first argument is a format control string, and the rest are data
3468 to be formatted under control of the string. See `format' for details.
3469
3470 If the first argument is nil or the empty string, clear any existing
3471 message; let the minibuffer contents show.
3472
3473 usage: (message-or-box FORMAT-STRING &rest ARGS) */)
3474 (ptrdiff_t nargs, Lisp_Object *args)
3475 {
3476 #ifdef HAVE_MENUS
3477 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
3478 && use_dialog_box)
3479 return Fmessage_box (nargs, args);
3480 #endif
3481 return Fmessage (nargs, args);
3482 }
3483
3484 DEFUN ("current-message", Fcurrent_message, Scurrent_message, 0, 0, 0,
3485 doc: /* Return the string currently displayed in the echo area, or nil if none. */)
3486 (void)
3487 {
3488 return current_message ();
3489 }
3490
3491
3492 DEFUN ("propertize", Fpropertize, Spropertize, 1, MANY, 0,
3493 doc: /* Return a copy of STRING with text properties added.
3494 First argument is the string to copy.
3495 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
3496 properties to add to the result.
3497 usage: (propertize STRING &rest PROPERTIES) */)
3498 (ptrdiff_t nargs, Lisp_Object *args)
3499 {
3500 Lisp_Object properties, string;
3501 struct gcpro gcpro1, gcpro2;
3502 ptrdiff_t i;
3503
3504 /* Number of args must be odd. */
3505 if ((nargs & 1) == 0)
3506 error ("Wrong number of arguments");
3507
3508 properties = string = Qnil;
3509 GCPRO2 (properties, string);
3510
3511 /* First argument must be a string. */
3512 CHECK_STRING (args[0]);
3513 string = Fcopy_sequence (args[0]);
3514
3515 for (i = 1; i < nargs; i += 2)
3516 properties = Fcons (args[i], Fcons (args[i + 1], properties));
3517
3518 Fadd_text_properties (make_number (0),
3519 make_number (SCHARS (string)),
3520 properties, string);
3521 RETURN_UNGCPRO (string);
3522 }
3523
3524 /* pWIDE is a conversion for printing large decimal integers (possibly with a
3525 trailing "d" that is ignored). pWIDElen is its length. signed_wide and
3526 unsigned_wide are signed and unsigned types for printing them. Use widest
3527 integers if available so that more floating point values can be converted. */
3528 #ifdef PRIdMAX
3529 # define pWIDE PRIdMAX
3530 enum { pWIDElen = sizeof PRIdMAX - 2 }; /* Don't count trailing "d". */
3531 typedef intmax_t signed_wide;
3532 typedef uintmax_t unsigned_wide;
3533 #else
3534 # define pWIDE pI
3535 enum { pWIDElen = sizeof pI - 1 };
3536 typedef EMACS_INT signed_wide;
3537 typedef EMACS_UINT unsigned_wide;
3538 #endif
3539
3540 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
3541 doc: /* Format a string out of a format-string and arguments.
3542 The first argument is a format control string.
3543 The other arguments are substituted into it to make the result, a string.
3544
3545 The format control string may contain %-sequences meaning to substitute
3546 the next available argument:
3547
3548 %s means print a string argument. Actually, prints any object, with `princ'.
3549 %d means print as number in decimal (%o octal, %x hex).
3550 %X is like %x, but uses upper case.
3551 %e means print a number in exponential notation.
3552 %f means print a number in decimal-point notation.
3553 %g means print a number in exponential notation
3554 or decimal-point notation, whichever uses fewer characters.
3555 %c means print a number as a single character.
3556 %S means print any object as an s-expression (using `prin1').
3557
3558 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.
3559 Use %% to put a single % into the output.
3560
3561 A %-sequence may contain optional flag, width, and precision
3562 specifiers, as follows:
3563
3564 %<flags><width><precision>character
3565
3566 where flags is [+ #-0]+, width is [0-9]+, and precision is .[0-9]+
3567
3568 The + flag character inserts a + before any positive number, while a
3569 space inserts a space before any positive number; these flags only
3570 affect %d, %e, %f, and %g sequences, and the + flag takes precedence.
3571 The # flag means to use an alternate display form for %o, %x, %X, %e,
3572 %f, and %g sequences. The - and 0 flags affect the width specifier,
3573 as described below.
3574
3575 The width specifier supplies a lower limit for the length of the
3576 printed representation. The padding, if any, normally goes on the
3577 left, but it goes on the right if the - flag is present. The padding
3578 character is normally a space, but it is 0 if the 0 flag is present.
3579 The - flag takes precedence over the 0 flag.
3580
3581 For %e, %f, and %g sequences, the number after the "." in the
3582 precision specifier says how many decimal places to show; if zero, the
3583 decimal point itself is omitted. For %s and %S, the precision
3584 specifier truncates the string to the given width.
3585
3586 usage: (format STRING &rest OBJECTS) */)
3587 (ptrdiff_t nargs, Lisp_Object *args)
3588 {
3589 ptrdiff_t n; /* The number of the next arg to substitute */
3590 char initial_buffer[4000];
3591 char *buf = initial_buffer;
3592 EMACS_INT bufsize = sizeof initial_buffer;
3593 EMACS_INT max_bufsize = STRING_BYTES_BOUND + 1;
3594 char *p;
3595 Lisp_Object buf_save_value IF_LINT (= {0});
3596 register char *format, *end, *format_start;
3597 EMACS_INT formatlen, nchars;
3598 /* Nonzero if the format is multibyte. */
3599 int multibyte_format = 0;
3600 /* Nonzero if the output should be a multibyte string,
3601 which is true if any of the inputs is one. */
3602 int multibyte = 0;
3603 /* When we make a multibyte string, we must pay attention to the
3604 byte combining problem, i.e., a byte may be combined with a
3605 multibyte character of the previous string. This flag tells if we
3606 must consider such a situation or not. */
3607 int maybe_combine_byte;
3608 Lisp_Object val;
3609 int arg_intervals = 0;
3610 USE_SAFE_ALLOCA;
3611
3612 /* discarded[I] is 1 if byte I of the format
3613 string was not copied into the output.
3614 It is 2 if byte I was not the first byte of its character. */
3615 char *discarded;
3616
3617 /* Each element records, for one argument,
3618 the start and end bytepos in the output string,
3619 whether the argument has been converted to string (e.g., due to "%S"),
3620 and whether the argument is a string with intervals.
3621 info[0] is unused. Unused elements have -1 for start. */
3622 struct info
3623 {
3624 EMACS_INT start, end;
3625 int converted_to_string;
3626 int intervals;
3627 } *info = 0;
3628
3629 /* It should not be necessary to GCPRO ARGS, because
3630 the caller in the interpreter should take care of that. */
3631
3632 CHECK_STRING (args[0]);
3633 format_start = SSDATA (args[0]);
3634 formatlen = SBYTES (args[0]);
3635
3636 /* Allocate the info and discarded tables. */
3637 {
3638 ptrdiff_t i;
3639 if ((SIZE_MAX - formatlen) / sizeof (struct info) <= nargs)
3640 memory_full (SIZE_MAX);
3641 SAFE_ALLOCA (info, struct info *, (nargs + 1) * sizeof *info + formatlen);
3642 discarded = (char *) &info[nargs + 1];
3643 for (i = 0; i < nargs + 1; i++)
3644 {
3645 info[i].start = -1;
3646 info[i].intervals = info[i].converted_to_string = 0;
3647 }
3648 memset (discarded, 0, formatlen);
3649 }
3650
3651 /* Try to determine whether the result should be multibyte.
3652 This is not always right; sometimes the result needs to be multibyte
3653 because of an object that we will pass through prin1,
3654 and in that case, we won't know it here. */
3655 multibyte_format = STRING_MULTIBYTE (args[0]);
3656 multibyte = multibyte_format;
3657 for (n = 1; !multibyte && n < nargs; n++)
3658 if (STRINGP (args[n]) && STRING_MULTIBYTE (args[n]))
3659 multibyte = 1;
3660
3661 /* If we start out planning a unibyte result,
3662 then discover it has to be multibyte, we jump back to retry. */
3663 retry:
3664
3665 p = buf;
3666 nchars = 0;
3667 n = 0;
3668
3669 /* Scan the format and store result in BUF. */
3670 format = format_start;
3671 end = format + formatlen;
3672 maybe_combine_byte = 0;
3673
3674 while (format != end)
3675 {
3676 /* The values of N and FORMAT when the loop body is entered. */
3677 ptrdiff_t n0 = n;
3678 char *format0 = format;
3679
3680 /* Bytes needed to represent the output of this conversion. */
3681 EMACS_INT convbytes;
3682
3683 if (*format == '%')
3684 {
3685 /* General format specifications look like
3686
3687 '%' [flags] [field-width] [precision] format
3688
3689 where
3690
3691 flags ::= [-+0# ]+
3692 field-width ::= [0-9]+
3693 precision ::= '.' [0-9]*
3694
3695 If a field-width is specified, it specifies to which width
3696 the output should be padded with blanks, if the output
3697 string is shorter than field-width.
3698
3699 If precision is specified, it specifies the number of
3700 digits to print after the '.' for floats, or the max.
3701 number of chars to print from a string. */
3702
3703 int minus_flag = 0;
3704 int plus_flag = 0;
3705 int space_flag = 0;
3706 int sharp_flag = 0;
3707 int zero_flag = 0;
3708 EMACS_INT field_width;
3709 int precision_given;
3710 uintmax_t precision = UINTMAX_MAX;
3711 char *num_end;
3712 char conversion;
3713
3714 while (1)
3715 {
3716 switch (*++format)
3717 {
3718 case '-': minus_flag = 1; continue;
3719 case '+': plus_flag = 1; continue;
3720 case ' ': space_flag = 1; continue;
3721 case '#': sharp_flag = 1; continue;
3722 case '0': zero_flag = 1; continue;
3723 }
3724 break;
3725 }
3726
3727 /* Ignore flags when sprintf ignores them. */
3728 space_flag &= ~ plus_flag;
3729 zero_flag &= ~ minus_flag;
3730
3731 {
3732 uintmax_t w = strtoumax (format, &num_end, 10);
3733 if (max_bufsize <= w)
3734 string_overflow ();
3735 field_width = w;
3736 }
3737 precision_given = *num_end == '.';
3738 if (precision_given)
3739 precision = strtoumax (num_end + 1, &num_end, 10);
3740 format = num_end;
3741
3742 if (format == end)
3743 error ("Format string ends in middle of format specifier");
3744
3745 memset (&discarded[format0 - format_start], 1, format - format0);
3746 conversion = *format;
3747 if (conversion == '%')
3748 goto copy_char;
3749 discarded[format - format_start] = 1;
3750 format++;
3751
3752 ++n;
3753 if (! (n < nargs))
3754 error ("Not enough arguments for format string");
3755
3756 /* For 'S', prin1 the argument, and then treat like 's'.
3757 For 's', princ any argument that is not a string or
3758 symbol. But don't do this conversion twice, which might
3759 happen after retrying. */
3760 if ((conversion == 'S'
3761 || (conversion == 's'
3762 && ! STRINGP (args[n]) && ! SYMBOLP (args[n]))))
3763 {
3764 if (! info[n].converted_to_string)
3765 {
3766 Lisp_Object noescape = conversion == 'S' ? Qnil : Qt;
3767 args[n] = Fprin1_to_string (args[n], noescape);
3768 info[n].converted_to_string = 1;
3769 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
3770 {
3771 multibyte = 1;
3772 goto retry;
3773 }
3774 }
3775 conversion = 's';
3776 }
3777 else if (conversion == 'c')
3778 {
3779 if (FLOATP (args[n]))
3780 {
3781 double d = XFLOAT_DATA (args[n]);
3782 args[n] = make_number (FIXNUM_OVERFLOW_P (d) ? -1 : d);
3783 }
3784
3785 if (INTEGERP (args[n]) && ! ASCII_CHAR_P (XINT (args[n])))
3786 {
3787 if (!multibyte)
3788 {
3789 multibyte = 1;
3790 goto retry;
3791 }
3792 args[n] = Fchar_to_string (args[n]);
3793 info[n].converted_to_string = 1;
3794 }
3795
3796 if (info[n].converted_to_string)
3797 conversion = 's';
3798 zero_flag = 0;
3799 }
3800
3801 if (SYMBOLP (args[n]))
3802 {
3803 args[n] = SYMBOL_NAME (args[n]);
3804 if (STRING_MULTIBYTE (args[n]) && ! multibyte)
3805 {
3806 multibyte = 1;
3807 goto retry;
3808 }
3809 }
3810
3811 if (conversion == 's')
3812 {
3813 /* handle case (precision[n] >= 0) */
3814
3815 EMACS_INT width, padding, nbytes;
3816 EMACS_INT nchars_string;
3817
3818 EMACS_INT prec = -1;
3819 if (precision_given && precision <= TYPE_MAXIMUM (EMACS_INT))
3820 prec = precision;
3821
3822 /* lisp_string_width ignores a precision of 0, but GNU
3823 libc functions print 0 characters when the precision
3824 is 0. Imitate libc behavior here. Changing
3825 lisp_string_width is the right thing, and will be
3826 done, but meanwhile we work with it. */
3827
3828 if (prec == 0)
3829 width = nchars_string = nbytes = 0;
3830 else
3831 {
3832 EMACS_INT nch, nby;
3833 width = lisp_string_width (args[n], prec, &nch, &nby);
3834 if (prec < 0)
3835 {
3836 nchars_string = SCHARS (args[n]);
3837 nbytes = SBYTES (args[n]);
3838 }
3839 else
3840 {
3841 nchars_string = nch;
3842 nbytes = nby;
3843 }
3844 }
3845
3846 convbytes = nbytes;
3847 if (convbytes && multibyte && ! STRING_MULTIBYTE (args[n]))
3848 convbytes = count_size_as_multibyte (SDATA (args[n]), nbytes);
3849
3850 padding = width < field_width ? field_width - width : 0;
3851
3852 if (max_bufsize - padding <= convbytes)
3853 string_overflow ();
3854 convbytes += padding;
3855 if (convbytes <= buf + bufsize - p)
3856 {
3857 if (! minus_flag)
3858 {
3859 memset (p, ' ', padding);
3860 p += padding;
3861 nchars += padding;
3862 }
3863
3864 if (p > buf
3865 && multibyte
3866 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
3867 && STRING_MULTIBYTE (args[n])
3868 && !CHAR_HEAD_P (SREF (args[n], 0)))
3869 maybe_combine_byte = 1;
3870
3871 p += copy_text (SDATA (args[n]), (unsigned char *) p,
3872 nbytes,
3873 STRING_MULTIBYTE (args[n]), multibyte);
3874
3875 info[n].start = nchars;
3876 nchars += nchars_string;
3877 info[n].end = nchars;
3878
3879 if (minus_flag)
3880 {
3881 memset (p, ' ', padding);
3882 p += padding;
3883 nchars += padding;
3884 }
3885
3886 /* If this argument has text properties, record where
3887 in the result string it appears. */
3888 if (STRING_INTERVALS (args[n]))
3889 info[n].intervals = arg_intervals = 1;
3890
3891 continue;
3892 }
3893 }
3894 else if (! (conversion == 'c' || conversion == 'd'
3895 || conversion == 'e' || conversion == 'f'
3896 || conversion == 'g' || conversion == 'i'
3897 || conversion == 'o' || conversion == 'x'
3898 || conversion == 'X'))
3899 error ("Invalid format operation %%%c",
3900 STRING_CHAR ((unsigned char *) format - 1));
3901 else if (! (INTEGERP (args[n]) || FLOATP (args[n])))
3902 error ("Format specifier doesn't match argument type");
3903 else
3904 {
3905 enum
3906 {
3907 /* Maximum precision for a %f conversion such that the
3908 trailing output digit might be nonzero. Any precisions
3909 larger than this will not yield useful information. */
3910 USEFUL_PRECISION_MAX =
3911 ((1 - DBL_MIN_EXP)
3912 * (FLT_RADIX == 2 || FLT_RADIX == 10 ? 1
3913 : FLT_RADIX == 16 ? 4
3914 : -1)),
3915
3916 /* Maximum number of bytes generated by any format, if
3917 precision is no more than DBL_USEFUL_PRECISION_MAX.
3918 On all practical hosts, %f is the worst case. */
3919 SPRINTF_BUFSIZE =
3920 sizeof "-." + (DBL_MAX_10_EXP + 1) + USEFUL_PRECISION_MAX
3921 };
3922 verify (0 < USEFUL_PRECISION_MAX);
3923
3924 int prec;
3925 EMACS_INT padding, sprintf_bytes;
3926 uintmax_t excess_precision, numwidth;
3927 uintmax_t leading_zeros = 0, trailing_zeros = 0;
3928
3929 char sprintf_buf[SPRINTF_BUFSIZE];
3930
3931 /* Copy of conversion specification, modified somewhat.
3932 At most three flags F can be specified at once. */
3933 char convspec[sizeof "%FFF.*d" + pWIDElen];
3934
3935 /* Avoid undefined behavior in underlying sprintf. */
3936 if (conversion == 'd' || conversion == 'i')
3937 sharp_flag = 0;
3938
3939 /* Create the copy of the conversion specification, with
3940 any width and precision removed, with ".*" inserted,
3941 and with pWIDE inserted for integer formats. */
3942 {
3943 char *f = convspec;
3944 *f++ = '%';
3945 *f = '-'; f += minus_flag;
3946 *f = '+'; f += plus_flag;
3947 *f = ' '; f += space_flag;
3948 *f = '#'; f += sharp_flag;
3949 *f = '0'; f += zero_flag;
3950 *f++ = '.';
3951 *f++ = '*';
3952 if (conversion == 'd' || conversion == 'i'
3953 || conversion == 'o' || conversion == 'x'
3954 || conversion == 'X')
3955 {
3956 memcpy (f, pWIDE, pWIDElen);
3957 f += pWIDElen;
3958 zero_flag &= ~ precision_given;
3959 }
3960 *f++ = conversion;
3961 *f = '\0';
3962 }
3963
3964 prec = -1;
3965 if (precision_given)
3966 prec = min (precision, USEFUL_PRECISION_MAX);
3967
3968 /* Use sprintf to format this number into sprintf_buf. Omit
3969 padding and excess precision, though, because sprintf limits
3970 output length to INT_MAX.
3971
3972 There are four types of conversion: double, unsigned
3973 char (passed as int), wide signed int, and wide
3974 unsigned int. Treat them separately because the
3975 sprintf ABI is sensitive to which type is passed. Be
3976 careful about integer overflow, NaNs, infinities, and
3977 conversions; for example, the min and max macros are
3978 not suitable here. */
3979 if (conversion == 'e' || conversion == 'f' || conversion == 'g')
3980 {
3981 double x = (INTEGERP (args[n])
3982 ? XINT (args[n])
3983 : XFLOAT_DATA (args[n]));
3984 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
3985 }
3986 else if (conversion == 'c')
3987 {
3988 /* Don't use sprintf here, as it might mishandle prec. */
3989 sprintf_buf[0] = XINT (args[n]);
3990 sprintf_bytes = prec != 0;
3991 }
3992 else if (conversion == 'd')
3993 {
3994 /* For float, maybe we should use "%1.0f"
3995 instead so it also works for values outside
3996 the integer range. */
3997 signed_wide x;
3998 if (INTEGERP (args[n]))
3999 x = XINT (args[n]);
4000 else
4001 {
4002 double d = XFLOAT_DATA (args[n]);
4003 if (d < 0)
4004 {
4005 x = TYPE_MINIMUM (signed_wide);
4006 if (x < d)
4007 x = d;
4008 }
4009 else
4010 {
4011 x = TYPE_MAXIMUM (signed_wide);
4012 if (d < x)
4013 x = d;
4014 }
4015 }
4016 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4017 }
4018 else
4019 {
4020 /* Don't sign-extend for octal or hex printing. */
4021 unsigned_wide x;
4022 if (INTEGERP (args[n]))
4023 x = XUINT (args[n]);
4024 else
4025 {
4026 double d = XFLOAT_DATA (args[n]);
4027 if (d < 0)
4028 x = 0;
4029 else
4030 {
4031 x = TYPE_MAXIMUM (unsigned_wide);
4032 if (d < x)
4033 x = d;
4034 }
4035 }
4036 sprintf_bytes = sprintf (sprintf_buf, convspec, prec, x);
4037 }
4038
4039 /* Now the length of the formatted item is known, except it omits
4040 padding and excess precision. Deal with excess precision
4041 first. This happens only when the format specifies
4042 ridiculously large precision. */
4043 excess_precision = precision - prec;
4044 if (excess_precision)
4045 {
4046 if (conversion == 'e' || conversion == 'f'
4047 || conversion == 'g')
4048 {
4049 if ((conversion == 'g' && ! sharp_flag)
4050 || ! ('0' <= sprintf_buf[sprintf_bytes - 1]
4051 && sprintf_buf[sprintf_bytes - 1] <= '9'))
4052 excess_precision = 0;
4053 else
4054 {
4055 if (conversion == 'g')
4056 {
4057 char *dot = strchr (sprintf_buf, '.');
4058 if (!dot)
4059 excess_precision = 0;
4060 }
4061 }
4062 trailing_zeros = excess_precision;
4063 }
4064 else
4065 leading_zeros = excess_precision;
4066 }
4067
4068 /* Compute the total bytes needed for this item, including
4069 excess precision and padding. */
4070 numwidth = sprintf_bytes + excess_precision;
4071 padding = numwidth < field_width ? field_width - numwidth : 0;
4072 if (max_bufsize - sprintf_bytes <= excess_precision
4073 || max_bufsize - padding <= numwidth)
4074 string_overflow ();
4075 convbytes = numwidth + padding;
4076
4077 if (convbytes <= buf + bufsize - p)
4078 {
4079 /* Copy the formatted item from sprintf_buf into buf,
4080 inserting padding and excess-precision zeros. */
4081
4082 char *src = sprintf_buf;
4083 char src0 = src[0];
4084 int exponent_bytes = 0;
4085 int signedp = src0 == '-' || src0 == '+' || src0 == ' ';
4086 int significand_bytes;
4087 if (zero_flag
4088 && ((src[signedp] >= '0' && src[signedp] <= '9')
4089 || (src[signedp] >= 'a' && src[signedp] <= 'f')
4090 || (src[signedp] >= 'A' && src[signedp] <= 'F')))
4091 {
4092 leading_zeros += padding;
4093 padding = 0;
4094 }
4095
4096 if (excess_precision
4097 && (conversion == 'e' || conversion == 'g'))
4098 {
4099 char *e = strchr (src, 'e');
4100 if (e)
4101 exponent_bytes = src + sprintf_bytes - e;
4102 }
4103
4104 if (! minus_flag)
4105 {
4106 memset (p, ' ', padding);
4107 p += padding;
4108 nchars += padding;
4109 }
4110
4111 *p = src0;
4112 src += signedp;
4113 p += signedp;
4114 memset (p, '0', leading_zeros);
4115 p += leading_zeros;
4116 significand_bytes = sprintf_bytes - signedp - exponent_bytes;
4117 memcpy (p, src, significand_bytes);
4118 p += significand_bytes;
4119 src += significand_bytes;
4120 memset (p, '0', trailing_zeros);
4121 p += trailing_zeros;
4122 memcpy (p, src, exponent_bytes);
4123 p += exponent_bytes;
4124
4125 info[n].start = nchars;
4126 nchars += leading_zeros + sprintf_bytes + trailing_zeros;
4127 info[n].end = nchars;
4128
4129 if (minus_flag)
4130 {
4131 memset (p, ' ', padding);
4132 p += padding;
4133 nchars += padding;
4134 }
4135
4136 continue;
4137 }
4138 }
4139 }
4140 else
4141 copy_char:
4142 {
4143 /* Copy a single character from format to buf. */
4144
4145 char *src = format;
4146 unsigned char str[MAX_MULTIBYTE_LENGTH];
4147
4148 if (multibyte_format)
4149 {
4150 /* Copy a whole multibyte character. */
4151 if (p > buf
4152 && !ASCII_BYTE_P (*((unsigned char *) p - 1))
4153 && !CHAR_HEAD_P (*format))
4154 maybe_combine_byte = 1;
4155
4156 do
4157 format++;
4158 while (! CHAR_HEAD_P (*format));
4159
4160 convbytes = format - format0;
4161 memset (&discarded[format0 + 1 - format_start], 2, convbytes - 1);
4162 }
4163 else
4164 {
4165 unsigned char uc = *format++;
4166 if (! multibyte || ASCII_BYTE_P (uc))
4167 convbytes = 1;
4168 else
4169 {
4170 int c = BYTE8_TO_CHAR (uc);
4171 convbytes = CHAR_STRING (c, str);
4172 src = (char *) str;
4173 }
4174 }
4175
4176 if (convbytes <= buf + bufsize - p)
4177 {
4178 memcpy (p, src, convbytes);
4179 p += convbytes;
4180 nchars++;
4181 continue;
4182 }
4183 }
4184
4185 /* There wasn't enough room to store this conversion or single
4186 character. CONVBYTES says how much room is needed. Allocate
4187 enough room (and then some) and do it again. */
4188 {
4189 EMACS_INT used = p - buf;
4190
4191 if (max_bufsize - used < convbytes)
4192 string_overflow ();
4193 bufsize = used + convbytes;
4194 bufsize = bufsize < max_bufsize / 2 ? bufsize * 2 : max_bufsize;
4195
4196 if (buf == initial_buffer)
4197 {
4198 buf = xmalloc (bufsize);
4199 sa_must_free = 1;
4200 buf_save_value = make_save_value (buf, 0);
4201 record_unwind_protect (safe_alloca_unwind, buf_save_value);
4202 memcpy (buf, initial_buffer, used);
4203 }
4204 else
4205 XSAVE_VALUE (buf_save_value)->pointer = buf = xrealloc (buf, bufsize);
4206
4207 p = buf + used;
4208 }
4209
4210 format = format0;
4211 n = n0;
4212 }
4213
4214 if (bufsize < p - buf)
4215 abort ();
4216
4217 if (maybe_combine_byte)
4218 nchars = multibyte_chars_in_text ((unsigned char *) buf, p - buf);
4219 val = make_specified_string (buf, nchars, p - buf, multibyte);
4220
4221 /* If we allocated BUF with malloc, free it too. */
4222 SAFE_FREE ();
4223
4224 /* If the format string has text properties, or any of the string
4225 arguments has text properties, set up text properties of the
4226 result string. */
4227
4228 if (STRING_INTERVALS (args[0]) || arg_intervals)
4229 {
4230 Lisp_Object len, new_len, props;
4231 struct gcpro gcpro1;
4232
4233 /* Add text properties from the format string. */
4234 len = make_number (SCHARS (args[0]));
4235 props = text_property_list (args[0], make_number (0), len, Qnil);
4236 GCPRO1 (props);
4237
4238 if (CONSP (props))
4239 {
4240 EMACS_INT bytepos = 0, position = 0, translated = 0;
4241 EMACS_INT argn = 1;
4242 Lisp_Object list;
4243
4244 /* Adjust the bounds of each text property
4245 to the proper start and end in the output string. */
4246
4247 /* Put the positions in PROPS in increasing order, so that
4248 we can do (effectively) one scan through the position
4249 space of the format string. */
4250 props = Fnreverse (props);
4251
4252 /* BYTEPOS is the byte position in the format string,
4253 POSITION is the untranslated char position in it,
4254 TRANSLATED is the translated char position in BUF,
4255 and ARGN is the number of the next arg we will come to. */
4256 for (list = props; CONSP (list); list = XCDR (list))
4257 {
4258 Lisp_Object item;
4259 EMACS_INT pos;
4260
4261 item = XCAR (list);
4262
4263 /* First adjust the property start position. */
4264 pos = XINT (XCAR (item));
4265
4266 /* Advance BYTEPOS, POSITION, TRANSLATED and ARGN
4267 up to this position. */
4268 for (; position < pos; bytepos++)
4269 {
4270 if (! discarded[bytepos])
4271 position++, translated++;
4272 else if (discarded[bytepos] == 1)
4273 {
4274 position++;
4275 if (translated == info[argn].start)
4276 {
4277 translated += info[argn].end - info[argn].start;
4278 argn++;
4279 }
4280 }
4281 }
4282
4283 XSETCAR (item, make_number (translated));
4284
4285 /* Likewise adjust the property end position. */
4286 pos = XINT (XCAR (XCDR (item)));
4287
4288 for (; position < pos; bytepos++)
4289 {
4290 if (! discarded[bytepos])
4291 position++, translated++;
4292 else if (discarded[bytepos] == 1)
4293 {
4294 position++;
4295 if (translated == info[argn].start)
4296 {
4297 translated += info[argn].end - info[argn].start;
4298 argn++;
4299 }
4300 }
4301 }
4302
4303 XSETCAR (XCDR (item), make_number (translated));
4304 }
4305
4306 add_text_properties_from_list (val, props, make_number (0));
4307 }
4308
4309 /* Add text properties from arguments. */
4310 if (arg_intervals)
4311 for (n = 1; n < nargs; ++n)
4312 if (info[n].intervals)
4313 {
4314 len = make_number (SCHARS (args[n]));
4315 new_len = make_number (info[n].end - info[n].start);
4316 props = text_property_list (args[n], make_number (0), len, Qnil);
4317 props = extend_property_ranges (props, new_len);
4318 /* If successive arguments have properties, be sure that
4319 the value of `composition' property be the copy. */
4320 if (n > 1 && info[n - 1].end)
4321 make_composition_value_copy (props);
4322 add_text_properties_from_list (val, props,
4323 make_number (info[n].start));
4324 }
4325
4326 UNGCPRO;
4327 }
4328
4329 return val;
4330 }
4331
4332 Lisp_Object
4333 format2 (const char *string1, Lisp_Object arg0, Lisp_Object arg1)
4334 {
4335 Lisp_Object args[3];
4336 args[0] = build_string (string1);
4337 args[1] = arg0;
4338 args[2] = arg1;
4339 return Fformat (3, args);
4340 }
4341 \f
4342 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
4343 doc: /* Return t if two characters match, optionally ignoring case.
4344 Both arguments must be characters (i.e. integers).
4345 Case is ignored if `case-fold-search' is non-nil in the current buffer. */)
4346 (register Lisp_Object c1, Lisp_Object c2)
4347 {
4348 int i1, i2;
4349 /* Check they're chars, not just integers, otherwise we could get array
4350 bounds violations in downcase. */
4351 CHECK_CHARACTER (c1);
4352 CHECK_CHARACTER (c2);
4353
4354 if (XINT (c1) == XINT (c2))
4355 return Qt;
4356 if (NILP (BVAR (current_buffer, case_fold_search)))
4357 return Qnil;
4358
4359 i1 = XFASTINT (c1);
4360 if (NILP (BVAR (current_buffer, enable_multibyte_characters))
4361 && ! ASCII_CHAR_P (i1))
4362 {
4363 MAKE_CHAR_MULTIBYTE (i1);
4364 }
4365 i2 = XFASTINT (c2);
4366 if (NILP (BVAR (current_buffer, enable_multibyte_characters))
4367 && ! ASCII_CHAR_P (i2))
4368 {
4369 MAKE_CHAR_MULTIBYTE (i2);
4370 }
4371 return (downcase (i1) == downcase (i2) ? Qt : Qnil);
4372 }
4373 \f
4374 /* Transpose the markers in two regions of the current buffer, and
4375 adjust the ones between them if necessary (i.e.: if the regions
4376 differ in size).
4377
4378 START1, END1 are the character positions of the first region.
4379 START1_BYTE, END1_BYTE are the byte positions.
4380 START2, END2 are the character positions of the second region.
4381 START2_BYTE, END2_BYTE are the byte positions.
4382
4383 Traverses the entire marker list of the buffer to do so, adding an
4384 appropriate amount to some, subtracting from some, and leaving the
4385 rest untouched. Most of this is copied from adjust_markers in insdel.c.
4386
4387 It's the caller's job to ensure that START1 <= END1 <= START2 <= END2. */
4388
4389 static void
4390 transpose_markers (EMACS_INT start1, EMACS_INT end1,
4391 EMACS_INT start2, EMACS_INT end2,
4392 EMACS_INT start1_byte, EMACS_INT end1_byte,
4393 EMACS_INT start2_byte, EMACS_INT end2_byte)
4394 {
4395 register EMACS_INT amt1, amt1_byte, amt2, amt2_byte, diff, diff_byte, mpos;
4396 register struct Lisp_Marker *marker;
4397
4398 /* Update point as if it were a marker. */
4399 if (PT < start1)
4400 ;
4401 else if (PT < end1)
4402 TEMP_SET_PT_BOTH (PT + (end2 - end1),
4403 PT_BYTE + (end2_byte - end1_byte));
4404 else if (PT < start2)
4405 TEMP_SET_PT_BOTH (PT + (end2 - start2) - (end1 - start1),
4406 (PT_BYTE + (end2_byte - start2_byte)
4407 - (end1_byte - start1_byte)));
4408 else if (PT < end2)
4409 TEMP_SET_PT_BOTH (PT - (start2 - start1),
4410 PT_BYTE - (start2_byte - start1_byte));
4411
4412 /* We used to adjust the endpoints here to account for the gap, but that
4413 isn't good enough. Even if we assume the caller has tried to move the
4414 gap out of our way, it might still be at start1 exactly, for example;
4415 and that places it `inside' the interval, for our purposes. The amount
4416 of adjustment is nontrivial if there's a `denormalized' marker whose
4417 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
4418 the dirty work to Fmarker_position, below. */
4419
4420 /* The difference between the region's lengths */
4421 diff = (end2 - start2) - (end1 - start1);
4422 diff_byte = (end2_byte - start2_byte) - (end1_byte - start1_byte);
4423
4424 /* For shifting each marker in a region by the length of the other
4425 region plus the distance between the regions. */
4426 amt1 = (end2 - start2) + (start2 - end1);
4427 amt2 = (end1 - start1) + (start2 - end1);
4428 amt1_byte = (end2_byte - start2_byte) + (start2_byte - end1_byte);
4429 amt2_byte = (end1_byte - start1_byte) + (start2_byte - end1_byte);
4430
4431 for (marker = BUF_MARKERS (current_buffer); marker; marker = marker->next)
4432 {
4433 mpos = marker->bytepos;
4434 if (mpos >= start1_byte && mpos < end2_byte)
4435 {
4436 if (mpos < end1_byte)
4437 mpos += amt1_byte;
4438 else if (mpos < start2_byte)
4439 mpos += diff_byte;
4440 else
4441 mpos -= amt2_byte;
4442 marker->bytepos = mpos;
4443 }
4444 mpos = marker->charpos;
4445 if (mpos >= start1 && mpos < end2)
4446 {
4447 if (mpos < end1)
4448 mpos += amt1;
4449 else if (mpos < start2)
4450 mpos += diff;
4451 else
4452 mpos -= amt2;
4453 }
4454 marker->charpos = mpos;
4455 }
4456 }
4457
4458 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
4459 doc: /* Transpose region STARTR1 to ENDR1 with STARTR2 to ENDR2.
4460 The regions should not be overlapping, because the size of the buffer is
4461 never changed in a transposition.
4462
4463 Optional fifth arg LEAVE-MARKERS, if non-nil, means don't update
4464 any markers that happen to be located in the regions.
4465
4466 Transposing beyond buffer boundaries is an error. */)
4467 (Lisp_Object startr1, Lisp_Object endr1, Lisp_Object startr2, Lisp_Object endr2, Lisp_Object leave_markers)
4468 {
4469 register EMACS_INT start1, end1, start2, end2;
4470 EMACS_INT start1_byte, start2_byte, len1_byte, len2_byte;
4471 EMACS_INT gap, len1, len_mid, len2;
4472 unsigned char *start1_addr, *start2_addr, *temp;
4473
4474 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2, tmp_interval3;
4475 Lisp_Object buf;
4476
4477 XSETBUFFER (buf, current_buffer);
4478 cur_intv = BUF_INTERVALS (current_buffer);
4479
4480 validate_region (&startr1, &endr1);
4481 validate_region (&startr2, &endr2);
4482
4483 start1 = XFASTINT (startr1);
4484 end1 = XFASTINT (endr1);
4485 start2 = XFASTINT (startr2);
4486 end2 = XFASTINT (endr2);
4487 gap = GPT;
4488
4489 /* Swap the regions if they're reversed. */
4490 if (start2 < end1)
4491 {
4492 register EMACS_INT glumph = start1;
4493 start1 = start2;
4494 start2 = glumph;
4495 glumph = end1;
4496 end1 = end2;
4497 end2 = glumph;
4498 }
4499
4500 len1 = end1 - start1;
4501 len2 = end2 - start2;
4502
4503 if (start2 < end1)
4504 error ("Transposed regions overlap");
4505 /* Nothing to change for adjacent regions with one being empty */
4506 else if ((start1 == end1 || start2 == end2) && end1 == start2)
4507 return Qnil;
4508
4509 /* The possibilities are:
4510 1. Adjacent (contiguous) regions, or separate but equal regions
4511 (no, really equal, in this case!), or
4512 2. Separate regions of unequal size.
4513
4514 The worst case is usually No. 2. It means that (aside from
4515 potential need for getting the gap out of the way), there also
4516 needs to be a shifting of the text between the two regions. So
4517 if they are spread far apart, we are that much slower... sigh. */
4518
4519 /* It must be pointed out that the really studly thing to do would
4520 be not to move the gap at all, but to leave it in place and work
4521 around it if necessary. This would be extremely efficient,
4522 especially considering that people are likely to do
4523 transpositions near where they are working interactively, which
4524 is exactly where the gap would be found. However, such code
4525 would be much harder to write and to read. So, if you are
4526 reading this comment and are feeling squirrely, by all means have
4527 a go! I just didn't feel like doing it, so I will simply move
4528 the gap the minimum distance to get it out of the way, and then
4529 deal with an unbroken array. */
4530
4531 /* Make sure the gap won't interfere, by moving it out of the text
4532 we will operate on. */
4533 if (start1 < gap && gap < end2)
4534 {
4535 if (gap - start1 < end2 - gap)
4536 move_gap (start1);
4537 else
4538 move_gap (end2);
4539 }
4540
4541 start1_byte = CHAR_TO_BYTE (start1);
4542 start2_byte = CHAR_TO_BYTE (start2);
4543 len1_byte = CHAR_TO_BYTE (end1) - start1_byte;
4544 len2_byte = CHAR_TO_BYTE (end2) - start2_byte;
4545
4546 #ifdef BYTE_COMBINING_DEBUG
4547 if (end1 == start2)
4548 {
4549 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4550 len2_byte, start1, start1_byte)
4551 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4552 len1_byte, end2, start2_byte + len2_byte)
4553 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4554 len1_byte, end2, start2_byte + len2_byte))
4555 abort ();
4556 }
4557 else
4558 {
4559 if (count_combining_before (BYTE_POS_ADDR (start2_byte),
4560 len2_byte, start1, start1_byte)
4561 || count_combining_before (BYTE_POS_ADDR (start1_byte),
4562 len1_byte, start2, start2_byte)
4563 || count_combining_after (BYTE_POS_ADDR (start2_byte),
4564 len2_byte, end1, start1_byte + len1_byte)
4565 || count_combining_after (BYTE_POS_ADDR (start1_byte),
4566 len1_byte, end2, start2_byte + len2_byte))
4567 abort ();
4568 }
4569 #endif
4570
4571 /* Hmmm... how about checking to see if the gap is large
4572 enough to use as the temporary storage? That would avoid an
4573 allocation... interesting. Later, don't fool with it now. */
4574
4575 /* Working without memmove, for portability (sigh), so must be
4576 careful of overlapping subsections of the array... */
4577
4578 if (end1 == start2) /* adjacent regions */
4579 {
4580 modify_region (current_buffer, start1, end2, 0);
4581 record_change (start1, len1 + len2);
4582
4583 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4584 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4585 /* Don't use Fset_text_properties: that can cause GC, which can
4586 clobber objects stored in the tmp_intervals. */
4587 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4588 if (!NULL_INTERVAL_P (tmp_interval3))
4589 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4590
4591 /* First region smaller than second. */
4592 if (len1_byte < len2_byte)
4593 {
4594 USE_SAFE_ALLOCA;
4595
4596 SAFE_ALLOCA (temp, unsigned char *, len2_byte);
4597
4598 /* Don't precompute these addresses. We have to compute them
4599 at the last minute, because the relocating allocator might
4600 have moved the buffer around during the xmalloc. */
4601 start1_addr = BYTE_POS_ADDR (start1_byte);
4602 start2_addr = BYTE_POS_ADDR (start2_byte);
4603
4604 memcpy (temp, start2_addr, len2_byte);
4605 memcpy (start1_addr + len2_byte, start1_addr, len1_byte);
4606 memcpy (start1_addr, temp, len2_byte);
4607 SAFE_FREE ();
4608 }
4609 else
4610 /* First region not smaller than second. */
4611 {
4612 USE_SAFE_ALLOCA;
4613
4614 SAFE_ALLOCA (temp, unsigned char *, len1_byte);
4615 start1_addr = BYTE_POS_ADDR (start1_byte);
4616 start2_addr = BYTE_POS_ADDR (start2_byte);
4617 memcpy (temp, start1_addr, len1_byte);
4618 memcpy (start1_addr, start2_addr, len2_byte);
4619 memcpy (start1_addr + len2_byte, temp, len1_byte);
4620 SAFE_FREE ();
4621 }
4622 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
4623 len1, current_buffer, 0);
4624 graft_intervals_into_buffer (tmp_interval2, start1,
4625 len2, current_buffer, 0);
4626 update_compositions (start1, start1 + len2, CHECK_BORDER);
4627 update_compositions (start1 + len2, end2, CHECK_TAIL);
4628 }
4629 /* Non-adjacent regions, because end1 != start2, bleagh... */
4630 else
4631 {
4632 len_mid = start2_byte - (start1_byte + len1_byte);
4633
4634 if (len1_byte == len2_byte)
4635 /* Regions are same size, though, how nice. */
4636 {
4637 USE_SAFE_ALLOCA;
4638
4639 modify_region (current_buffer, start1, end1, 0);
4640 modify_region (current_buffer, start2, end2, 0);
4641 record_change (start1, len1);
4642 record_change (start2, len2);
4643 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4644 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4645
4646 tmp_interval3 = validate_interval_range (buf, &startr1, &endr1, 0);
4647 if (!NULL_INTERVAL_P (tmp_interval3))
4648 set_text_properties_1 (startr1, endr1, Qnil, buf, tmp_interval3);
4649
4650 tmp_interval3 = validate_interval_range (buf, &startr2, &endr2, 0);
4651 if (!NULL_INTERVAL_P (tmp_interval3))
4652 set_text_properties_1 (startr2, endr2, Qnil, buf, tmp_interval3);
4653
4654 SAFE_ALLOCA (temp, unsigned char *, len1_byte);
4655 start1_addr = BYTE_POS_ADDR (start1_byte);
4656 start2_addr = BYTE_POS_ADDR (start2_byte);
4657 memcpy (temp, start1_addr, len1_byte);
4658 memcpy (start1_addr, start2_addr, len2_byte);
4659 memcpy (start2_addr, temp, len1_byte);
4660 SAFE_FREE ();
4661
4662 graft_intervals_into_buffer (tmp_interval1, start2,
4663 len1, current_buffer, 0);
4664 graft_intervals_into_buffer (tmp_interval2, start1,
4665 len2, current_buffer, 0);
4666 }
4667
4668 else if (len1_byte < len2_byte) /* Second region larger than first */
4669 /* Non-adjacent & unequal size, area between must also be shifted. */
4670 {
4671 USE_SAFE_ALLOCA;
4672
4673 modify_region (current_buffer, start1, end2, 0);
4674 record_change (start1, (end2 - start1));
4675 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4676 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4677 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4678
4679 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4680 if (!NULL_INTERVAL_P (tmp_interval3))
4681 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4682
4683 /* holds region 2 */
4684 SAFE_ALLOCA (temp, unsigned char *, len2_byte);
4685 start1_addr = BYTE_POS_ADDR (start1_byte);
4686 start2_addr = BYTE_POS_ADDR (start2_byte);
4687 memcpy (temp, start2_addr, len2_byte);
4688 memcpy (start1_addr + len_mid + len2_byte, start1_addr, len1_byte);
4689 memmove (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4690 memcpy (start1_addr, temp, len2_byte);
4691 SAFE_FREE ();
4692
4693 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4694 len1, current_buffer, 0);
4695 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4696 len_mid, current_buffer, 0);
4697 graft_intervals_into_buffer (tmp_interval2, start1,
4698 len2, current_buffer, 0);
4699 }
4700 else
4701 /* Second region smaller than first. */
4702 {
4703 USE_SAFE_ALLOCA;
4704
4705 record_change (start1, (end2 - start1));
4706 modify_region (current_buffer, start1, end2, 0);
4707
4708 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
4709 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
4710 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
4711
4712 tmp_interval3 = validate_interval_range (buf, &startr1, &endr2, 0);
4713 if (!NULL_INTERVAL_P (tmp_interval3))
4714 set_text_properties_1 (startr1, endr2, Qnil, buf, tmp_interval3);
4715
4716 /* holds region 1 */
4717 SAFE_ALLOCA (temp, unsigned char *, len1_byte);
4718 start1_addr = BYTE_POS_ADDR (start1_byte);
4719 start2_addr = BYTE_POS_ADDR (start2_byte);
4720 memcpy (temp, start1_addr, len1_byte);
4721 memcpy (start1_addr, start2_addr, len2_byte);
4722 memcpy (start1_addr + len2_byte, start1_addr + len1_byte, len_mid);
4723 memcpy (start1_addr + len2_byte + len_mid, temp, len1_byte);
4724 SAFE_FREE ();
4725
4726 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
4727 len1, current_buffer, 0);
4728 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
4729 len_mid, current_buffer, 0);
4730 graft_intervals_into_buffer (tmp_interval2, start1,
4731 len2, current_buffer, 0);
4732 }
4733
4734 update_compositions (start1, start1 + len2, CHECK_BORDER);
4735 update_compositions (end2 - len1, end2, CHECK_BORDER);
4736 }
4737
4738 /* When doing multiple transpositions, it might be nice
4739 to optimize this. Perhaps the markers in any one buffer
4740 should be organized in some sorted data tree. */
4741 if (NILP (leave_markers))
4742 {
4743 transpose_markers (start1, end1, start2, end2,
4744 start1_byte, start1_byte + len1_byte,
4745 start2_byte, start2_byte + len2_byte);
4746 fix_start_end_in_overlays (start1, end2);
4747 }
4748
4749 signal_after_change (start1, end2 - start1, end2 - start1);
4750 return Qnil;
4751 }
4752
4753 \f
4754 void
4755 syms_of_editfns (void)
4756 {
4757 environbuf = 0;
4758 initial_tz = 0;
4759
4760 Qbuffer_access_fontify_functions
4761 = intern_c_string ("buffer-access-fontify-functions");
4762 staticpro (&Qbuffer_access_fontify_functions);
4763
4764 DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
4765 doc: /* Non-nil means text motion commands don't notice fields. */);
4766 Vinhibit_field_text_motion = Qnil;
4767
4768 DEFVAR_LISP ("buffer-access-fontify-functions",
4769 Vbuffer_access_fontify_functions,
4770 doc: /* List of functions called by `buffer-substring' to fontify if necessary.
4771 Each function is called with two arguments which specify the range
4772 of the buffer being accessed. */);
4773 Vbuffer_access_fontify_functions = Qnil;
4774
4775 {
4776 Lisp_Object obuf;
4777 obuf = Fcurrent_buffer ();
4778 /* Do this here, because init_buffer_once is too early--it won't work. */
4779 Fset_buffer (Vprin1_to_string_buffer);
4780 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
4781 Fset (Fmake_local_variable (intern_c_string ("buffer-access-fontify-functions")),
4782 Qnil);
4783 Fset_buffer (obuf);
4784 }
4785
4786 DEFVAR_LISP ("buffer-access-fontified-property",
4787 Vbuffer_access_fontified_property,
4788 doc: /* Property which (if non-nil) indicates text has been fontified.
4789 `buffer-substring' need not call the `buffer-access-fontify-functions'
4790 functions if all the text being accessed has this property. */);
4791 Vbuffer_access_fontified_property = Qnil;
4792
4793 DEFVAR_LISP ("system-name", Vsystem_name,
4794 doc: /* The host name of the machine Emacs is running on. */);
4795
4796 DEFVAR_LISP ("user-full-name", Vuser_full_name,
4797 doc: /* The full name of the user logged in. */);
4798
4799 DEFVAR_LISP ("user-login-name", Vuser_login_name,
4800 doc: /* The user's name, taken from environment variables if possible. */);
4801
4802 DEFVAR_LISP ("user-real-login-name", Vuser_real_login_name,
4803 doc: /* The user's name, based upon the real uid only. */);
4804
4805 DEFVAR_LISP ("operating-system-release", Voperating_system_release,
4806 doc: /* The release of the operating system Emacs is running on. */);
4807
4808 defsubr (&Spropertize);
4809 defsubr (&Schar_equal);
4810 defsubr (&Sgoto_char);
4811 defsubr (&Sstring_to_char);
4812 defsubr (&Schar_to_string);
4813 defsubr (&Sbyte_to_string);
4814 defsubr (&Sbuffer_substring);
4815 defsubr (&Sbuffer_substring_no_properties);
4816 defsubr (&Sbuffer_string);
4817
4818 defsubr (&Spoint_marker);
4819 defsubr (&Smark_marker);
4820 defsubr (&Spoint);
4821 defsubr (&Sregion_beginning);
4822 defsubr (&Sregion_end);
4823
4824 staticpro (&Qfield);
4825 Qfield = intern_c_string ("field");
4826 staticpro (&Qboundary);
4827 Qboundary = intern_c_string ("boundary");
4828 defsubr (&Sfield_beginning);
4829 defsubr (&Sfield_end);
4830 defsubr (&Sfield_string);
4831 defsubr (&Sfield_string_no_properties);
4832 defsubr (&Sdelete_field);
4833 defsubr (&Sconstrain_to_field);
4834
4835 defsubr (&Sline_beginning_position);
4836 defsubr (&Sline_end_position);
4837
4838 /* defsubr (&Smark); */
4839 /* defsubr (&Sset_mark); */
4840 defsubr (&Ssave_excursion);
4841 defsubr (&Ssave_current_buffer);
4842
4843 defsubr (&Sbufsize);
4844 defsubr (&Spoint_max);
4845 defsubr (&Spoint_min);
4846 defsubr (&Spoint_min_marker);
4847 defsubr (&Spoint_max_marker);
4848 defsubr (&Sgap_position);
4849 defsubr (&Sgap_size);
4850 defsubr (&Sposition_bytes);
4851 defsubr (&Sbyte_to_position);
4852
4853 defsubr (&Sbobp);
4854 defsubr (&Seobp);
4855 defsubr (&Sbolp);
4856 defsubr (&Seolp);
4857 defsubr (&Sfollowing_char);
4858 defsubr (&Sprevious_char);
4859 defsubr (&Schar_after);
4860 defsubr (&Schar_before);
4861 defsubr (&Sinsert);
4862 defsubr (&Sinsert_before_markers);
4863 defsubr (&Sinsert_and_inherit);
4864 defsubr (&Sinsert_and_inherit_before_markers);
4865 defsubr (&Sinsert_char);
4866 defsubr (&Sinsert_byte);
4867
4868 defsubr (&Suser_login_name);
4869 defsubr (&Suser_real_login_name);
4870 defsubr (&Suser_uid);
4871 defsubr (&Suser_real_uid);
4872 defsubr (&Suser_full_name);
4873 defsubr (&Semacs_pid);
4874 defsubr (&Scurrent_time);
4875 defsubr (&Sget_internal_run_time);
4876 defsubr (&Sformat_time_string);
4877 defsubr (&Sfloat_time);
4878 defsubr (&Sdecode_time);
4879 defsubr (&Sencode_time);
4880 defsubr (&Scurrent_time_string);
4881 defsubr (&Scurrent_time_zone);
4882 defsubr (&Sset_time_zone_rule);
4883 defsubr (&Ssystem_name);
4884 defsubr (&Smessage);
4885 defsubr (&Smessage_box);
4886 defsubr (&Smessage_or_box);
4887 defsubr (&Scurrent_message);
4888 defsubr (&Sformat);
4889
4890 defsubr (&Sinsert_buffer_substring);
4891 defsubr (&Scompare_buffer_substrings);
4892 defsubr (&Ssubst_char_in_region);
4893 defsubr (&Stranslate_region_internal);
4894 defsubr (&Sdelete_region);
4895 defsubr (&Sdelete_and_extract_region);
4896 defsubr (&Swiden);
4897 defsubr (&Snarrow_to_region);
4898 defsubr (&Ssave_restriction);
4899 defsubr (&Stranspose_regions);
4900 }