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