1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
21 #include <sys/types.h>
32 #include "intervals.h"
38 #define min(a, b) ((a) < (b) ? (a) : (b))
39 #define max(a, b) ((a) > (b) ? (a) : (b))
41 /* Some static data, and a function to initialize it for each run */
43 Lisp_Object Vsystem_name
;
44 Lisp_Object Vuser_real_name
; /* login name of current user ID */
45 Lisp_Object Vuser_full_name
; /* full name of current user */
46 Lisp_Object Vuser_name
; /* user name from LOGNAME or USER */
52 register unsigned char *p
, *q
, *r
;
53 struct passwd
*pw
; /* password entry for the current user */
54 extern char *index ();
57 /* Set up system_name even when dumping. */
61 /* Don't bother with this on initial start when just dumping out */
64 #endif /* not CANNOT_DUMP */
66 pw
= (struct passwd
*) getpwuid (getuid ());
67 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
69 /* Get the effective user name, by consulting environment variables,
70 or the effective uid if those are unset. */
71 user_name
= (char *) getenv ("LOGNAME");
73 user_name
= (char *) getenv ("USER");
76 pw
= (struct passwd
*) getpwuid (geteuid ());
77 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
79 Vuser_name
= build_string (user_name
);
81 /* If the user name claimed in the environment vars differs from
82 the real uid, use the claimed name to find the full name. */
83 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
85 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
87 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
88 q
= (unsigned char *) index (p
, ',');
89 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
91 #ifdef AMPERSAND_FULL_NAME
92 p
= XSTRING (Vuser_full_name
)->data
;
93 q
= (char *) index (p
, '&');
94 /* Substitute the login name for the &, upcasing the first character. */
97 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
100 strcat (r
, XSTRING (Vuser_name
)->data
);
101 r
[q
- p
] = UPCASE (r
[q
- p
]);
103 Vuser_full_name
= build_string (r
);
105 #endif /* AMPERSAND_FULL_NAME */
108 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
109 "Convert arg CHAR to a one-character string containing that character.")
117 return make_string (&c
, 1);
120 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
121 "Convert arg STRING to a character, the first character of that string.")
123 register Lisp_Object str
;
125 register Lisp_Object val
;
126 register struct Lisp_String
*p
;
127 CHECK_STRING (str
, 0);
131 XFASTINT (val
) = ((unsigned char *) p
->data
)[0];
141 register Lisp_Object mark
;
142 mark
= Fmake_marker ();
143 Fset_marker (mark
, make_number (val
), Qnil
);
147 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
148 "Return value of point, as an integer.\n\
149 Beginning of buffer is position (point-min)")
153 XFASTINT (temp
) = point
;
157 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
158 "Return value of point, as a marker object.")
161 return buildmark (point
);
165 clip_to_bounds (lower
, num
, upper
)
166 int lower
, num
, upper
;
170 else if (num
> upper
)
176 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
177 "Set point to POSITION, a number or marker.\n\
178 Beginning of buffer is position (point-min), end is (point-max).")
180 register Lisp_Object n
;
182 CHECK_NUMBER_COERCE_MARKER (n
, 0);
184 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
189 region_limit (beginningp
)
192 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
193 register Lisp_Object m
;
194 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
195 && NILP (current_buffer
->mark_active
))
196 Fsignal (Qmark_inactive
, Qnil
);
197 m
= Fmarker_position (current_buffer
->mark
);
198 if (NILP (m
)) error ("There is no region now");
199 if ((point
< XFASTINT (m
)) == beginningp
)
200 return (make_number (point
));
205 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
206 "Return position of beginning of region, as an integer.")
209 return (region_limit (1));
212 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
213 "Return position of end of region, as an integer.")
216 return (region_limit (0));
219 #if 0 /* now in lisp code */
220 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
221 "Return this buffer's mark value as integer, or nil if no mark.\n\
222 If you are using this in an editing command, you are most likely making\n\
223 a mistake; see the documentation of `set-mark'.")
226 return Fmarker_position (current_buffer
->mark
);
228 #endif /* commented out code */
230 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
231 "Return this buffer's mark, as a marker object.\n\
232 Watch out! Moving this marker changes the mark position.\n\
233 If you set the marker not to point anywhere, the buffer will have no mark.")
236 return current_buffer
->mark
;
239 #if 0 /* this is now in lisp code */
240 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
241 "Set this buffer's mark to POS. Don't use this function!\n\
242 That is to say, don't use this function unless you want\n\
243 the user to see that the mark has moved, and you want the previous\n\
244 mark position to be lost.\n\
246 Normally, when a new mark is set, the old one should go on the stack.\n\
247 This is why most applications should use push-mark, not set-mark.\n\
249 Novice programmers often try to use the mark for the wrong purposes.\n\
250 The mark saves a location for the user's convenience.\n\
251 Most editing commands should not alter the mark.\n\
252 To remember a location for internal use in the Lisp program,\n\
253 store it in a Lisp variable. Example:\n\
255 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
261 current_buffer
->mark
= Qnil
;
264 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
266 if (NILP (current_buffer
->mark
))
267 current_buffer
->mark
= Fmake_marker ();
269 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
272 #endif /* commented-out code */
275 save_excursion_save ()
277 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
280 return Fcons (Fpoint_marker (),
281 Fcons (Fcopy_marker (current_buffer
->mark
),
282 Fcons (visible
? Qt
: Qnil
,
283 current_buffer
->mark_active
)));
287 save_excursion_restore (info
)
288 register Lisp_Object info
;
290 register Lisp_Object tem
, tem1
, omark
, nmark
;
292 tem
= Fmarker_buffer (Fcar (info
));
293 /* If buffer being returned to is now deleted, avoid error */
294 /* Otherwise could get error here while unwinding to top level
296 /* In that case, Fmarker_buffer returns nil now. */
302 unchain_marker (tem
);
303 tem
= Fcar (Fcdr (info
));
304 omark
= Fmarker_position (current_buffer
->mark
);
305 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
306 nmark
= Fmarker_position (tem
);
307 unchain_marker (tem
);
308 tem
= Fcdr (Fcdr (info
));
309 #if 0 /* We used to make the current buffer visible in the selected window
310 if that was true previously. That avoids some anomalies.
311 But it creates others, and it wasn't documented, and it is simpler
312 and cleaner never to alter the window/buffer connections. */
315 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
316 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
319 tem1
= current_buffer
->mark_active
;
320 current_buffer
->mark_active
= Fcdr (tem
);
321 if (!NILP (Vrun_hooks
))
323 /* If mark is active now, and either was not active
324 or was at a different place, run the activate hook. */
325 if (! NILP (current_buffer
->mark_active
))
327 if (! EQ (omark
, nmark
))
328 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
330 /* If mark has ceased to be active, run deactivate hook. */
331 else if (! NILP (tem1
))
332 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
337 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
338 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
339 Executes BODY just like `progn'.\n\
340 The values of point, mark and the current buffer are restored\n\
341 even in case of abnormal exit (throw or error).\n\
342 The state of activation of the mark is also restored.")
346 register Lisp_Object val
;
347 int count
= specpdl_ptr
- specpdl
;
349 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
352 return unbind_to (count
, val
);
355 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
356 "Return the number of characters in the current buffer.")
360 XFASTINT (temp
) = Z
- BEG
;
364 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
365 "Return the minimum permissible value of point in the current buffer.\n\
366 This is 1, unless narrowing (a buffer restriction) is in effect.")
370 XFASTINT (temp
) = BEGV
;
374 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
375 "Return a marker to the minimum permissible value of point in this buffer.\n\
376 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
379 return buildmark (BEGV
);
382 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
383 "Return the maximum permissible value of point in the current buffer.\n\
384 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
385 is in effect, in which case it is less.")
389 XFASTINT (temp
) = ZV
;
393 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
394 "Return a marker to the maximum permissible value of point in this buffer.\n\
395 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
396 is in effect, in which case it is less.")
399 return buildmark (ZV
);
402 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
403 "Return the character following point, as a number.\n\
404 At the end of the buffer or accessible region, return 0.")
411 XFASTINT (temp
) = FETCH_CHAR (point
);
415 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
416 "Return the character preceding point, as a number.\n\
417 At the beginning of the buffer or accessible region, return 0.")
424 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
428 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
429 "Return T if point is at the beginning of the buffer.\n\
430 If the buffer is narrowed, this means the beginning of the narrowed part.")
438 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
439 "Return T if point is at the end of the buffer.\n\
440 If the buffer is narrowed, this means the end of the narrowed part.")
448 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
449 "Return T if point is at the beginning of a line.")
452 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
457 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
458 "Return T if point is at the end of a line.\n\
459 `End of a line' includes point being at the end of the buffer.")
462 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
467 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
468 "Return character in current buffer at position POS.\n\
469 POS is an integer or a buffer pointer.\n\
470 If POS is out of range, the value is nil.")
474 register Lisp_Object val
;
477 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
480 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
482 XFASTINT (val
) = FETCH_CHAR (n
);
486 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
487 "Return the name under which the user logged in, as a string.\n\
488 This is based on the effective uid, not the real uid.\n\
489 Also, if the environment variable LOGNAME or USER is set,\n\
490 that determines the value of this function.")
496 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
498 "Return the name of the user's real uid, as a string.\n\
499 This ignores the environment variables LOGNAME and USER, so it differs from\n\
500 `user-login-name' when running under `su'.")
503 return Vuser_real_name
;
506 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
507 "Return the effective uid of Emacs, as an integer.")
510 return make_number (geteuid ());
513 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
514 "Return the real uid of Emacs, as an integer.")
517 return make_number (getuid ());
520 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
521 "Return the full name of the user logged in, as a string.")
524 return Vuser_full_name
;
527 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
528 "Return the name of the machine you are running on, as a string.")
534 /* For the benefit of callers who don't want to include lisp.h */
538 return (char *) XSTRING (Vsystem_name
)->data
;
541 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
542 "Return the process ID of Emacs, as an integer.")
545 return make_number (getpid ());
548 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
549 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
550 The time is returned as a list of three integers. The first has the\n\
551 most significant 16 bits of the seconds, while the second has the\n\
552 least significant 16 bits. The third integer gives the microsecond\n\
555 The microsecond count is zero on systems that do not provide\n\
556 resolution finer than a second.")
560 Lisp_Object result
[3];
563 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
564 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
565 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
567 return Flist (3, result
);
572 lisp_time_argument (specified_time
, result
)
573 Lisp_Object specified_time
;
576 if (NILP (specified_time
))
577 return time (result
) != -1;
580 Lisp_Object high
, low
;
581 high
= Fcar (specified_time
);
582 CHECK_NUMBER (high
, 0);
583 low
= Fcdr (specified_time
);
584 if (XTYPE (low
) == Lisp_Cons
)
586 CHECK_NUMBER (low
, 0);
587 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
588 return *result
>> 16 == XINT (high
);
592 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
593 "Return the current time, as a human-readable string.\n\
594 Programs can use this function to decode a time,\n\
595 since the number of columns in each field is fixed.\n\
596 The format is `Sun Sep 16 01:03:52 1973'.\n\
597 If an argument is given, it specifies a time to format\n\
598 instead of the current time. The argument should have the form:\n\
601 (HIGH LOW . IGNORED).\n\
602 Thus, you can use times obtained from `current-time'\n\
603 and from `file-attributes'.")
605 Lisp_Object specified_time
;
611 if (! lisp_time_argument (specified_time
, &value
))
613 tem
= (char *) ctime (&value
);
615 strncpy (buf
, tem
, 24);
618 return build_string (buf
);
621 #define TM_YEAR_ORIGIN 1900
623 /* Yield A - B, measured in seconds. */
628 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
629 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
630 /* Some compilers can't handle this as a single return statement. */
632 /* difference in day of year */
633 a
->tm_yday
- b
->tm_yday
634 /* + intervening leap days */
635 + ((ay
>> 2) - (by
>> 2))
637 + ((ay
/100 >> 2) - (by
/100 >> 2))
638 /* + difference in years * 365 */
639 + (long)(ay
-by
) * 365
641 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
642 + (a
->tm_min
- b
->tm_min
))
643 + (a
->tm_sec
- b
->tm_sec
));
646 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
647 "Return the offset and name for the local time zone.\n\
648 This returns a list of the form (OFFSET NAME).\n\
649 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
650 A negative value means west of Greenwich.\n\
651 NAME is a string giving the name of the time zone.\n\
652 If an argument is given, it specifies when the time zone offset is determined\n\
653 instead of using the current time. The argument should have the form:\n\
656 (HIGH LOW . IGNORED).\n\
657 Thus, you can use times obtained from `current-time'\n\
658 and from `file-attributes'.\n\
660 Some operating systems cannot provide all this information to Emacs;\n\
661 in this case, `current-time-zone' returns a list containing nil for\n\
662 the data it can't find.")
664 Lisp_Object specified_time
;
669 if (lisp_time_argument (specified_time
, &value
)
670 && (t
= gmtime (&value
)) != 0)
676 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
677 t
= localtime (&value
);
678 offset
= difftm (t
, &gmt
);
682 s
= (char *)t
->tm_zone
;
683 #else /* not HAVE_TM_ZONE */
685 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
686 s
= tzname
[t
->tm_isdst
];
688 #endif /* not HAVE_TM_ZONE */
691 /* No local time zone name is available; use "+-NNNN" instead. */
692 int am
= (offset
< 0 ? -offset
: offset
) / 60;
693 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
696 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
699 return Fmake_list (2, Qnil
);
711 /* Callers passing one argument to Finsert need not gcpro the
712 argument "array", since the only element of the array will
713 not be used after calling insert or insert_from_string, so
714 we don't care if it gets trashed. */
716 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
717 "Insert the arguments, either strings or characters, at point.\n\
718 Point moves forward so that it ends up after the inserted text.\n\
719 Any other markers at the point of insertion remain before the text.")
722 register Lisp_Object
*args
;
725 register Lisp_Object tem
;
728 for (argnum
= 0; argnum
< nargs
; argnum
++)
732 if (XTYPE (tem
) == Lisp_Int
)
737 else if (XTYPE (tem
) == Lisp_String
)
739 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
743 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
751 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
753 "Insert the arguments at point, inheriting properties from adjoining text.\n\
754 Point moves forward so that it ends up after the inserted text.\n\
755 Any other markers at the point of insertion remain before the text.")
758 register Lisp_Object
*args
;
761 register Lisp_Object tem
;
764 for (argnum
= 0; argnum
< nargs
; argnum
++)
768 if (XTYPE (tem
) == Lisp_Int
)
771 insert_and_inherit (str
, 1);
773 else if (XTYPE (tem
) == Lisp_String
)
775 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
779 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
787 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
788 "Insert strings or characters at point, relocating markers after the text.\n\
789 Point moves forward so that it ends up after the inserted text.\n\
790 Any other markers at the point of insertion also end up after the text.")
793 register Lisp_Object
*args
;
796 register Lisp_Object tem
;
799 for (argnum
= 0; argnum
< nargs
; argnum
++)
803 if (XTYPE (tem
) == Lisp_Int
)
806 insert_before_markers (str
, 1);
808 else if (XTYPE (tem
) == Lisp_String
)
810 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
814 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
822 DEFUN ("insert-before-markers-and-inherit",
823 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
825 "Insert text at point, relocating markers and inheriting properties.\n\
826 Point moves forward so that it ends up after the inserted text.\n\
827 Any other markers at the point of insertion also end up after the text.")
830 register Lisp_Object
*args
;
833 register Lisp_Object tem
;
836 for (argnum
= 0; argnum
< nargs
; argnum
++)
840 if (XTYPE (tem
) == Lisp_Int
)
843 insert_before_markers_and_inherit (str
, 1);
845 else if (XTYPE (tem
) == Lisp_String
)
847 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
851 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
859 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
860 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
861 Point and all markers are affected as in the function `insert'.\n\
862 Both arguments are required.\n\
863 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
864 from adjoining text, if those properties are sticky.")
865 (chr
, count
, inherit
)
866 Lisp_Object chr
, count
, inherit
;
868 register unsigned char *string
;
872 CHECK_NUMBER (chr
, 0);
873 CHECK_NUMBER (count
, 1);
878 strlen
= min (n
, 256);
879 string
= (unsigned char *) alloca (strlen
);
880 for (i
= 0; i
< strlen
; i
++)
881 string
[i
] = XFASTINT (chr
);
885 insert_and_inherit (string
, strlen
);
887 insert (string
, strlen
);
896 /* Making strings from buffer contents. */
898 /* Return a Lisp_String containing the text of the current buffer from
899 START to END. If text properties are in use and the current buffer
900 has properties in the range specified, the resulting string will also
903 We don't want to use plain old make_string here, because it calls
904 make_uninit_string, which can cause the buffer arena to be
905 compacted. make_string has no way of knowing that the data has
906 been moved, and thus copies the wrong data into the string. This
907 doesn't effect most of the other users of make_string, so it should
908 be left as is. But we should use this function when conjuring
909 buffer substrings. */
912 make_buffer_string (start
, end
)
915 Lisp_Object result
, tem
, tem1
;
917 if (start
< GPT
&& GPT
< end
)
920 result
= make_uninit_string (end
- start
);
921 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
923 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
924 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
926 #ifdef USE_TEXT_PROPERTIES
927 if (XINT (tem
) != end
|| !NILP (tem1
))
928 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
934 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
935 "Return the contents of part of the current buffer as a string.\n\
936 The two arguments START and END are character positions;\n\
937 they can be in either order.")
941 register int beg
, end
;
943 validate_region (&b
, &e
);
947 return make_buffer_string (beg
, end
);
950 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
951 "Return the contents of the current buffer as a string.")
954 return make_buffer_string (BEGV
, ZV
);
957 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
959 "Insert before point a substring of the contents of buffer BUFFER.\n\
960 BUFFER may be a buffer or a buffer name.\n\
961 Arguments START and END are character numbers specifying the substring.\n\
962 They default to the beginning and the end of BUFFER.")
964 Lisp_Object buf
, b
, e
;
966 register int beg
, end
, temp
, len
, opoint
, start
;
967 register struct buffer
*bp
;
970 buffer
= Fget_buffer (buf
);
973 bp
= XBUFFER (buffer
);
979 CHECK_NUMBER_COERCE_MARKER (b
, 0);
986 CHECK_NUMBER_COERCE_MARKER (e
, 1);
991 temp
= beg
, beg
= end
, end
= temp
;
993 /* Move the gap or create enough gap in the current buffer. */
997 if (GAP_SIZE
< end
- beg
)
998 make_gap (end
- beg
- GAP_SIZE
);
1004 if (!(BUF_BEGV (bp
) <= beg
1006 && end
<= BUF_ZV (bp
)))
1007 args_out_of_range (b
, e
);
1009 /* Now the actual insertion will not do any gap motion,
1010 so it matters not if BUF is the current buffer. */
1011 if (beg
< BUF_GPT (bp
))
1013 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
1014 beg
= min (end
, BUF_GPT (bp
));
1017 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1019 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1020 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1021 opoint
, len
, current_buffer
, 0);
1026 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1028 "Compare two substrings of two buffers; return result as number.\n\
1029 the value is -N if first string is less after N-1 chars,\n\
1030 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1031 Each substring is represented as three arguments: BUFFER, START and END.\n\
1032 That makes six args in all, three for each substring.\n\n\
1033 The value of `case-fold-search' in the current buffer\n\
1034 determines whether case is significant or ignored.")
1035 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1036 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1038 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1039 register struct buffer
*bp1
, *bp2
;
1040 register unsigned char *trt
1041 = (!NILP (current_buffer
->case_fold_search
)
1042 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1044 /* Find the first buffer and its substring. */
1047 bp1
= current_buffer
;
1051 buf1
= Fget_buffer (buffer1
);
1054 bp1
= XBUFFER (buf1
);
1058 begp1
= BUF_BEGV (bp1
);
1061 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1062 begp1
= XINT (start1
);
1065 endp1
= BUF_ZV (bp1
);
1068 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1069 endp1
= XINT (end1
);
1073 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1075 if (!(BUF_BEGV (bp1
) <= begp1
1077 && endp1
<= BUF_ZV (bp1
)))
1078 args_out_of_range (start1
, end1
);
1080 /* Likewise for second substring. */
1083 bp2
= current_buffer
;
1087 buf2
= Fget_buffer (buffer2
);
1090 bp2
= XBUFFER (buffer2
);
1094 begp2
= BUF_BEGV (bp2
);
1097 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1098 begp2
= XINT (start2
);
1101 endp2
= BUF_ZV (bp2
);
1104 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1105 endp2
= XINT (end2
);
1109 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1111 if (!(BUF_BEGV (bp2
) <= begp2
1113 && endp2
<= BUF_ZV (bp2
)))
1114 args_out_of_range (start2
, end2
);
1116 len1
= endp1
- begp1
;
1117 len2
= endp2
- begp2
;
1122 for (i
= 0; i
< length
; i
++)
1124 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1125 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1132 return make_number (- 1 - i
);
1134 return make_number (i
+ 1);
1137 /* The strings match as far as they go.
1138 If one is shorter, that one is less. */
1140 return make_number (length
+ 1);
1141 else if (length
< len2
)
1142 return make_number (- length
- 1);
1144 /* Same length too => they are equal. */
1145 return make_number (0);
1148 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1149 Ssubst_char_in_region
, 4, 5, 0,
1150 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1151 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1152 and don't mark the buffer as really changed.")
1153 (start
, end
, fromchar
, tochar
, noundo
)
1154 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1156 register int pos
, stop
, look
;
1159 validate_region (&start
, &end
);
1160 CHECK_NUMBER (fromchar
, 2);
1161 CHECK_NUMBER (tochar
, 3);
1165 look
= XINT (fromchar
);
1169 if (FETCH_CHAR (pos
) == look
)
1173 modify_region (current_buffer
, XINT (start
), stop
);
1175 if (! NILP (noundo
))
1177 if (MODIFF
- 1 == current_buffer
->save_modified
)
1178 current_buffer
->save_modified
++;
1179 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1180 current_buffer
->auto_save_modified
++;
1187 record_change (pos
, 1);
1188 FETCH_CHAR (pos
) = XINT (tochar
);
1194 signal_after_change (XINT (start
),
1195 stop
- XINT (start
), stop
- XINT (start
));
1200 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1201 "From START to END, translate characters according to TABLE.\n\
1202 TABLE is a string; the Nth character in it is the mapping\n\
1203 for the character with code N. Returns the number of characters changed.")
1207 register Lisp_Object table
;
1209 register int pos
, stop
; /* Limits of the region. */
1210 register unsigned char *tt
; /* Trans table. */
1211 register int oc
; /* Old character. */
1212 register int nc
; /* New character. */
1213 int cnt
; /* Number of changes made. */
1214 Lisp_Object z
; /* Return. */
1215 int size
; /* Size of translate table. */
1217 validate_region (&start
, &end
);
1218 CHECK_STRING (table
, 2);
1220 size
= XSTRING (table
)->size
;
1221 tt
= XSTRING (table
)->data
;
1225 modify_region (current_buffer
, pos
, stop
);
1228 for (; pos
< stop
; ++pos
)
1230 oc
= FETCH_CHAR (pos
);
1236 record_change (pos
, 1);
1237 FETCH_CHAR (pos
) = nc
;
1238 signal_after_change (pos
, 1, 1);
1248 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1249 "Delete the text between point and mark.\n\
1250 When called from a program, expects two arguments,\n\
1251 positions (integers or markers) specifying the stretch to be deleted.")
1255 validate_region (&b
, &e
);
1256 del_range (XINT (b
), XINT (e
));
1260 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1261 "Remove restrictions (narrowing) from current buffer.\n\
1262 This allows the buffer's full text to be seen and edited.")
1266 SET_BUF_ZV (current_buffer
, Z
);
1268 /* Changing the buffer bounds invalidates any recorded current column. */
1269 invalidate_current_column ();
1273 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1274 "Restrict editing in this buffer to the current region.\n\
1275 The rest of the text becomes temporarily invisible and untouchable\n\
1276 but is not deleted; if you save the buffer in a file, the invisible\n\
1277 text is included in the file. \\[widen] makes all visible again.\n\
1278 See also `save-restriction'.\n\
1280 When calling from a program, pass two arguments; positions (integers\n\
1281 or markers) bounding the text that should remain visible.")
1283 register Lisp_Object b
, e
;
1287 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1288 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1290 if (XINT (b
) > XINT (e
))
1297 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1298 args_out_of_range (b
, e
);
1300 BEGV
= XFASTINT (b
);
1301 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1302 if (point
< XFASTINT (b
))
1303 SET_PT (XFASTINT (b
));
1304 if (point
> XFASTINT (e
))
1305 SET_PT (XFASTINT (e
));
1307 /* Changing the buffer bounds invalidates any recorded current column. */
1308 invalidate_current_column ();
1313 save_restriction_save ()
1315 register Lisp_Object bottom
, top
;
1316 /* Note: I tried using markers here, but it does not win
1317 because insertion at the end of the saved region
1318 does not advance mh and is considered "outside" the saved region. */
1319 XFASTINT (bottom
) = BEGV
- BEG
;
1320 XFASTINT (top
) = Z
- ZV
;
1322 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1326 save_restriction_restore (data
)
1329 register struct buffer
*buf
;
1330 register int newhead
, newtail
;
1331 register Lisp_Object tem
;
1333 buf
= XBUFFER (XCONS (data
)->car
);
1335 data
= XCONS (data
)->cdr
;
1337 tem
= XCONS (data
)->car
;
1338 newhead
= XINT (tem
);
1339 tem
= XCONS (data
)->cdr
;
1340 newtail
= XINT (tem
);
1341 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1346 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1347 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1350 /* If point is outside the new visible range, move it inside. */
1352 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1357 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1358 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1359 The buffer's restrictions make parts of the beginning and end invisible.\n\
1360 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1361 This special form, `save-restriction', saves the current buffer's restrictions\n\
1362 when it is entered, and restores them when it is exited.\n\
1363 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1364 The old restrictions settings are restored\n\
1365 even in case of abnormal exit (throw or error).\n\
1367 The value returned is the value of the last form in BODY.\n\
1369 `save-restriction' can get confused if, within the BODY, you widen\n\
1370 and then make changes outside the area within the saved restrictions.\n\
1372 Note: if you are using both `save-excursion' and `save-restriction',\n\
1373 use `save-excursion' outermost:\n\
1374 (save-excursion (save-restriction ...))")
1378 register Lisp_Object val
;
1379 int count
= specpdl_ptr
- specpdl
;
1381 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1382 val
= Fprogn (body
);
1383 return unbind_to (count
, val
);
1386 /* Buffer for the most recent text displayed by Fmessage. */
1387 static char *message_text
;
1389 /* Allocated length of that buffer. */
1390 static int message_length
;
1392 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1393 "Print a one-line message at the bottom of the screen.\n\
1394 The first argument is a control string.\n\
1395 It may contain %s or %d or %c to print successive following arguments.\n\
1396 %s means print an argument as a string, %d means print as number in decimal,\n\
1397 %c means print a number as a single character.\n\
1398 The argument used by %s must be a string or a symbol;\n\
1399 the argument used by %d or %c must be a number.\n\
1400 If the first argument is nil, clear any existing message; let the\n\
1401 minibuffer contents show.")
1413 register Lisp_Object val
;
1414 val
= Fformat (nargs
, args
);
1415 /* Copy the data so that it won't move when we GC. */
1418 message_text
= (char *)xmalloc (80);
1419 message_length
= 80;
1421 if (XSTRING (val
)->size
> message_length
)
1423 message_length
= XSTRING (val
)->size
;
1424 message_text
= (char *)xrealloc (message_text
, message_length
);
1426 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1427 message2 (message_text
, XSTRING (val
)->size
);
1432 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1433 "Format a string out of a control-string and arguments.\n\
1434 The first argument is a control string.\n\
1435 The other arguments are substituted into it to make the result, a string.\n\
1436 It may contain %-sequences meaning to substitute the next argument.\n\
1437 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1438 %d means print as number in decimal (%o octal, %x hex).\n\
1439 %c means print a number as a single character.\n\
1440 %S means print any object as an s-expression (using prin1).\n\
1441 The argument used for %d, %o, %x or %c must be a number.\n\
1442 Use %% to put a single % into the output.")
1445 register Lisp_Object
*args
;
1447 register int n
; /* The number of the next arg to substitute */
1448 register int total
= 5; /* An estimate of the final length */
1450 register unsigned char *format
, *end
;
1452 extern char *index ();
1453 /* It should not be necessary to GCPRO ARGS, because
1454 the caller in the interpreter should take care of that. */
1456 CHECK_STRING (args
[0], 0);
1457 format
= XSTRING (args
[0])->data
;
1458 end
= format
+ XSTRING (args
[0])->size
;
1461 while (format
!= end
)
1462 if (*format
++ == '%')
1466 /* Process a numeric arg and skip it. */
1467 minlen
= atoi (format
);
1472 while ((*format
>= '0' && *format
<= '9')
1473 || *format
== '-' || *format
== ' ' || *format
== '.')
1478 else if (++n
>= nargs
)
1479 error ("not enough arguments for format string");
1480 else if (*format
== 'S')
1482 /* For `S', prin1 the argument and then treat like a string. */
1483 register Lisp_Object tem
;
1484 tem
= Fprin1_to_string (args
[n
], Qnil
);
1488 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1490 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1493 else if (XTYPE (args
[n
]) == Lisp_String
)
1496 if (*format
!= 's' && *format
!= 'S')
1497 error ("format specifier doesn't match argument type");
1498 total
+= XSTRING (args
[n
])->size
;
1500 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1501 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1503 #ifdef LISP_FLOAT_TYPE
1504 /* The following loop assumes the Lisp type indicates
1505 the proper way to pass the argument.
1506 So make sure we have a flonum if the argument should
1508 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1509 args
[n
] = Ffloat (args
[n
]);
1513 #ifdef LISP_FLOAT_TYPE
1514 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1516 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1517 args
[n
] = Ftruncate (args
[n
]);
1523 /* Anything but a string, convert to a string using princ. */
1524 register Lisp_Object tem
;
1525 tem
= Fprin1_to_string (args
[n
], Qt
);
1532 register int nstrings
= n
+ 1;
1534 /* Allocate twice as many strings as we have %-escapes; floats occupy
1535 two slots, and we're not sure how many of those we have. */
1536 register unsigned char **strings
1537 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1541 for (n
= 0; n
< nstrings
; n
++)
1544 strings
[i
++] = (unsigned char *) "";
1545 else if (XTYPE (args
[n
]) == Lisp_Int
)
1546 /* We checked above that the corresponding format effector
1547 isn't %s, which would cause MPV. */
1548 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1549 #ifdef LISP_FLOAT_TYPE
1550 else if (XTYPE (args
[n
]) == Lisp_Float
)
1552 union { double d
; int half
[2]; } u
;
1554 u
.d
= XFLOAT (args
[n
])->data
;
1555 strings
[i
++] = (unsigned char *) u
.half
[0];
1556 strings
[i
++] = (unsigned char *) u
.half
[1];
1560 strings
[i
++] = XSTRING (args
[n
])->data
;
1563 /* Format it in bigger and bigger buf's until it all fits. */
1566 buf
= (char *) alloca (total
+ 1);
1569 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1570 if (buf
[total
- 1] == 0)
1578 return make_string (buf
, length
);
1584 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1585 int arg0
, arg1
, arg2
, arg3
, arg4
;
1599 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1601 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1603 return build_string (buf
);
1606 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1607 "Return t if two characters match, optionally ignoring case.\n\
1608 Both arguments must be characters (i.e. integers).\n\
1609 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1611 register Lisp_Object c1
, c2
;
1613 unsigned char *downcase
= DOWNCASE_TABLE
;
1614 CHECK_NUMBER (c1
, 0);
1615 CHECK_NUMBER (c2
, 1);
1617 if (!NILP (current_buffer
->case_fold_search
)
1618 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1619 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1620 : XINT (c1
) == XINT (c2
))
1625 /* Transpose the markers in two regions of the current buffer, and
1626 adjust the ones between them if necessary (i.e.: if the regions
1629 Traverses the entire marker list of the buffer to do so, adding an
1630 appropriate amount to some, subtracting from some, and leaving the
1631 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1633 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1636 transpose_markers (start1
, end1
, start2
, end2
)
1637 register int start1
, end1
, start2
, end2
;
1639 register int amt1
, amt2
, diff
, mpos
;
1640 register Lisp_Object marker
;
1642 /* Update point as if it were a marker. */
1646 TEMP_SET_PT (PT
+ (end2
- end1
));
1647 else if (PT
< start2
)
1648 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1650 TEMP_SET_PT (PT
- (start2
- start1
));
1652 /* We used to adjust the endpoints here to account for the gap, but that
1653 isn't good enough. Even if we assume the caller has tried to move the
1654 gap out of our way, it might still be at start1 exactly, for example;
1655 and that places it `inside' the interval, for our purposes. The amount
1656 of adjustment is nontrivial if there's a `denormalized' marker whose
1657 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1658 the dirty work to Fmarker_position, below. */
1660 /* The difference between the region's lengths */
1661 diff
= (end2
- start2
) - (end1
- start1
);
1663 /* For shifting each marker in a region by the length of the other
1664 * region plus the distance between the regions.
1666 amt1
= (end2
- start2
) + (start2
- end1
);
1667 amt2
= (end1
- start1
) + (start2
- end1
);
1669 for (marker
= current_buffer
->markers
; !NILP (marker
);
1670 marker
= XMARKER (marker
)->chain
)
1672 mpos
= Fmarker_position (marker
);
1673 if (mpos
>= start1
&& mpos
< end2
)
1677 else if (mpos
< start2
)
1681 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1682 XMARKER (marker
)->bufpos
= mpos
;
1687 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1688 "Transpose region START1 to END1 with START2 to END2.\n\
1689 The regions may not be overlapping, because the size of the buffer is\n\
1690 never changed in a transposition.\n\
1692 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1693 any markers that happen to be located in the regions.\n\
1695 Transposing beyond buffer boundaries is an error.")
1696 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1697 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1699 register int start1
, end1
, start2
, end2
,
1700 gap
, len1
, len_mid
, len2
;
1701 unsigned char *start1_addr
, *start2_addr
, *temp
;
1703 #ifdef USE_TEXT_PROPERTIES
1704 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1705 cur_intv
= current_buffer
->intervals
;
1706 #endif /* USE_TEXT_PROPERTIES */
1708 validate_region (&startr1
, &endr1
);
1709 validate_region (&startr2
, &endr2
);
1711 start1
= XFASTINT (startr1
);
1712 end1
= XFASTINT (endr1
);
1713 start2
= XFASTINT (startr2
);
1714 end2
= XFASTINT (endr2
);
1717 /* Swap the regions if they're reversed. */
1720 register int glumph
= start1
;
1728 len1
= end1
- start1
;
1729 len2
= end2
- start2
;
1732 error ("transposed regions not properly ordered");
1733 else if (start1
== end1
|| start2
== end2
)
1734 error ("transposed region may not be of length 0");
1736 /* The possibilities are:
1737 1. Adjacent (contiguous) regions, or separate but equal regions
1738 (no, really equal, in this case!), or
1739 2. Separate regions of unequal size.
1741 The worst case is usually No. 2. It means that (aside from
1742 potential need for getting the gap out of the way), there also
1743 needs to be a shifting of the text between the two regions. So
1744 if they are spread far apart, we are that much slower... sigh. */
1746 /* It must be pointed out that the really studly thing to do would
1747 be not to move the gap at all, but to leave it in place and work
1748 around it if necessary. This would be extremely efficient,
1749 especially considering that people are likely to do
1750 transpositions near where they are working interactively, which
1751 is exactly where the gap would be found. However, such code
1752 would be much harder to write and to read. So, if you are
1753 reading this comment and are feeling squirrely, by all means have
1754 a go! I just didn't feel like doing it, so I will simply move
1755 the gap the minimum distance to get it out of the way, and then
1756 deal with an unbroken array. */
1758 /* Make sure the gap won't interfere, by moving it out of the text
1759 we will operate on. */
1760 if (start1
< gap
&& gap
< end2
)
1762 if (gap
- start1
< end2
- gap
)
1768 /* Hmmm... how about checking to see if the gap is large
1769 enough to use as the temporary storage? That would avoid an
1770 allocation... interesting. Later, don't fool with it now. */
1772 /* Working without memmove, for portability (sigh), so must be
1773 careful of overlapping subsections of the array... */
1775 if (end1
== start2
) /* adjacent regions */
1777 modify_region (current_buffer
, start1
, end2
);
1778 record_change (start1
, len1
+ len2
);
1780 #ifdef USE_TEXT_PROPERTIES
1781 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1782 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1783 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1784 #endif /* USE_TEXT_PROPERTIES */
1786 /* First region smaller than second. */
1789 /* We use alloca only if it is small,
1790 because we want to avoid stack overflow. */
1792 temp
= (unsigned char *) xmalloc (len2
);
1794 temp
= (unsigned char *) alloca (len2
);
1796 /* Don't precompute these addresses. We have to compute them
1797 at the last minute, because the relocating allocator might
1798 have moved the buffer around during the xmalloc. */
1799 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1800 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1802 bcopy (start2_addr
, temp
, len2
);
1803 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1804 bcopy (temp
, start1_addr
, len2
);
1809 /* First region not smaller than second. */
1812 temp
= (unsigned char *) xmalloc (len1
);
1814 temp
= (unsigned char *) alloca (len1
);
1815 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1816 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1817 bcopy (start1_addr
, temp
, len1
);
1818 bcopy (start2_addr
, start1_addr
, len2
);
1819 bcopy (temp
, start1_addr
+ len2
, len1
);
1823 #ifdef USE_TEXT_PROPERTIES
1824 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1825 len1
, current_buffer
, 0);
1826 graft_intervals_into_buffer (tmp_interval2
, start1
,
1827 len2
, current_buffer
, 0);
1828 #endif /* USE_TEXT_PROPERTIES */
1830 /* Non-adjacent regions, because end1 != start2, bleagh... */
1834 /* Regions are same size, though, how nice. */
1836 modify_region (current_buffer
, start1
, end1
);
1837 modify_region (current_buffer
, start2
, end2
);
1838 record_change (start1
, len1
);
1839 record_change (start2
, len2
);
1840 #ifdef USE_TEXT_PROPERTIES
1841 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1842 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1843 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
1844 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
1845 #endif /* USE_TEXT_PROPERTIES */
1848 temp
= (unsigned char *) xmalloc (len1
);
1850 temp
= (unsigned char *) alloca (len1
);
1851 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1852 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1853 bcopy (start1_addr
, temp
, len1
);
1854 bcopy (start2_addr
, start1_addr
, len2
);
1855 bcopy (temp
, start2_addr
, len1
);
1858 #ifdef USE_TEXT_PROPERTIES
1859 graft_intervals_into_buffer (tmp_interval1
, start2
,
1860 len1
, current_buffer
, 0);
1861 graft_intervals_into_buffer (tmp_interval2
, start1
,
1862 len2
, current_buffer
, 0);
1863 #endif /* USE_TEXT_PROPERTIES */
1866 else if (len1
< len2
) /* Second region larger than first */
1867 /* Non-adjacent & unequal size, area between must also be shifted. */
1869 len_mid
= start2
- end1
;
1870 modify_region (current_buffer
, start1
, end2
);
1871 record_change (start1
, (end2
- start1
));
1872 #ifdef USE_TEXT_PROPERTIES
1873 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1874 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1875 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1876 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1877 #endif /* USE_TEXT_PROPERTIES */
1879 /* holds region 2 */
1881 temp
= (unsigned char *) xmalloc (len2
);
1883 temp
= (unsigned char *) alloca (len2
);
1884 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1885 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1886 bcopy (start2_addr
, temp
, len2
);
1887 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
1888 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
1889 bcopy (temp
, start1_addr
, len2
);
1892 #ifdef USE_TEXT_PROPERTIES
1893 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
1894 len1
, current_buffer
, 0);
1895 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
1896 len_mid
, current_buffer
, 0);
1897 graft_intervals_into_buffer (tmp_interval2
, start1
,
1898 len2
, current_buffer
, 0);
1899 #endif /* USE_TEXT_PROPERTIES */
1902 /* Second region smaller than first. */
1904 len_mid
= start2
- end1
;
1905 record_change (start1
, (end2
- start1
));
1906 modify_region (current_buffer
, start1
, end2
);
1908 #ifdef USE_TEXT_PROPERTIES
1909 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1910 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1911 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1912 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1913 #endif /* USE_TEXT_PROPERTIES */
1915 /* holds region 1 */
1917 temp
= (unsigned char *) xmalloc (len1
);
1919 temp
= (unsigned char *) alloca (len1
);
1920 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1921 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1922 bcopy (start1_addr
, temp
, len1
);
1923 bcopy (start2_addr
, start1_addr
, len2
);
1924 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
1925 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
1928 #ifdef USE_TEXT_PROPERTIES
1929 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
1930 len1
, current_buffer
, 0);
1931 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
1932 len_mid
, current_buffer
, 0);
1933 graft_intervals_into_buffer (tmp_interval2
, start1
,
1934 len2
, current_buffer
, 0);
1935 #endif /* USE_TEXT_PROPERTIES */
1939 /* todo: this will be slow, because for every transposition, we
1940 traverse the whole friggin marker list. Possible solutions:
1941 somehow get a list of *all* the markers across multiple
1942 transpositions and do it all in one swell phoop. Or maybe modify
1943 Emacs' marker code to keep an ordered list or tree. This might
1944 be nicer, and more beneficial in the long run, but would be a
1945 bunch of work. Plus the way they're arranged now is nice. */
1946 if (NILP (leave_markers
))
1948 transpose_markers (start1
, end1
, start2
, end2
);
1949 fix_overlays_in_range (start1
, end2
);
1959 staticpro (&Vuser_name
);
1960 staticpro (&Vuser_full_name
);
1961 staticpro (&Vuser_real_name
);
1962 staticpro (&Vsystem_name
);
1964 defsubr (&Schar_equal
);
1965 defsubr (&Sgoto_char
);
1966 defsubr (&Sstring_to_char
);
1967 defsubr (&Schar_to_string
);
1968 defsubr (&Sbuffer_substring
);
1969 defsubr (&Sbuffer_string
);
1971 defsubr (&Spoint_marker
);
1972 defsubr (&Smark_marker
);
1974 defsubr (&Sregion_beginning
);
1975 defsubr (&Sregion_end
);
1976 /* defsubr (&Smark); */
1977 /* defsubr (&Sset_mark); */
1978 defsubr (&Ssave_excursion
);
1980 defsubr (&Sbufsize
);
1981 defsubr (&Spoint_max
);
1982 defsubr (&Spoint_min
);
1983 defsubr (&Spoint_min_marker
);
1984 defsubr (&Spoint_max_marker
);
1990 defsubr (&Sfollowing_char
);
1991 defsubr (&Sprevious_char
);
1992 defsubr (&Schar_after
);
1994 defsubr (&Sinsert_before_markers
);
1995 defsubr (&Sinsert_and_inherit
);
1996 defsubr (&Sinsert_and_inherit_before_markers
);
1997 defsubr (&Sinsert_char
);
1999 defsubr (&Suser_login_name
);
2000 defsubr (&Suser_real_login_name
);
2001 defsubr (&Suser_uid
);
2002 defsubr (&Suser_real_uid
);
2003 defsubr (&Suser_full_name
);
2004 defsubr (&Semacs_pid
);
2005 defsubr (&Scurrent_time
);
2006 defsubr (&Scurrent_time_string
);
2007 defsubr (&Scurrent_time_zone
);
2008 defsubr (&Ssystem_name
);
2009 defsubr (&Smessage
);
2012 defsubr (&Sinsert_buffer_substring
);
2013 defsubr (&Scompare_buffer_substrings
);
2014 defsubr (&Ssubst_char_in_region
);
2015 defsubr (&Stranslate_region
);
2016 defsubr (&Sdelete_region
);
2018 defsubr (&Snarrow_to_region
);
2019 defsubr (&Ssave_restriction
);
2020 defsubr (&Stranspose_regions
);