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. */
59 Vsystem_name
= build_string (get_system_name ());
60 p
= XSTRING (Vsystem_name
)->data
;
63 if (*p
== ' ' || *p
== '\t')
69 /* Don't bother with this on initial start when just dumping out */
72 #endif /* not CANNOT_DUMP */
74 pw
= (struct passwd
*) getpwuid (getuid ());
75 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
77 /* Get the effective user name, by consulting environment variables,
78 or the effective uid if those are unset. */
79 user_name
= (char *) getenv ("LOGNAME");
81 user_name
= (char *) getenv ("USER");
84 pw
= (struct passwd
*) getpwuid (geteuid ());
85 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
87 Vuser_name
= build_string (user_name
);
89 /* If the user name claimed in the environment vars differs from
90 the real uid, use the claimed name to find the full name. */
91 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
93 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
95 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
96 q
= (unsigned char *) index (p
, ',');
97 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
99 #ifdef AMPERSAND_FULL_NAME
100 p
= XSTRING (Vuser_full_name
)->data
;
101 q
= (char *) index (p
, '&');
102 /* Substitute the login name for the &, upcasing the first character. */
105 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
108 strcat (r
, XSTRING (Vuser_name
)->data
);
109 r
[q
- p
] = UPCASE (r
[q
- p
]);
111 Vuser_full_name
= build_string (r
);
113 #endif /* AMPERSAND_FULL_NAME */
116 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
117 "Convert arg CHAR to a one-character string containing that character.")
125 return make_string (&c
, 1);
128 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
129 "Convert arg STRING to a character, the first character of that string.")
131 register Lisp_Object str
;
133 register Lisp_Object val
;
134 register struct Lisp_String
*p
;
135 CHECK_STRING (str
, 0);
139 XFASTINT (val
) = ((unsigned char *) p
->data
)[0];
149 register Lisp_Object mark
;
150 mark
= Fmake_marker ();
151 Fset_marker (mark
, make_number (val
), Qnil
);
155 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
156 "Return value of point, as an integer.\n\
157 Beginning of buffer is position (point-min)")
161 XFASTINT (temp
) = point
;
165 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
166 "Return value of point, as a marker object.")
169 return buildmark (point
);
173 clip_to_bounds (lower
, num
, upper
)
174 int lower
, num
, upper
;
178 else if (num
> upper
)
184 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
185 "Set point to POSITION, a number or marker.\n\
186 Beginning of buffer is position (point-min), end is (point-max).")
188 register Lisp_Object n
;
190 CHECK_NUMBER_COERCE_MARKER (n
, 0);
192 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
197 region_limit (beginningp
)
200 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
201 register Lisp_Object m
;
202 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
203 && NILP (current_buffer
->mark_active
))
204 Fsignal (Qmark_inactive
, Qnil
);
205 m
= Fmarker_position (current_buffer
->mark
);
206 if (NILP (m
)) error ("There is no region now");
207 if ((point
< XFASTINT (m
)) == beginningp
)
208 return (make_number (point
));
213 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
214 "Return position of beginning of region, as an integer.")
217 return (region_limit (1));
220 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
221 "Return position of end of region, as an integer.")
224 return (region_limit (0));
227 #if 0 /* now in lisp code */
228 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
229 "Return this buffer's mark value as integer, or nil if no mark.\n\
230 If you are using this in an editing command, you are most likely making\n\
231 a mistake; see the documentation of `set-mark'.")
234 return Fmarker_position (current_buffer
->mark
);
236 #endif /* commented out code */
238 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
239 "Return this buffer's mark, as a marker object.\n\
240 Watch out! Moving this marker changes the mark position.\n\
241 If you set the marker not to point anywhere, the buffer will have no mark.")
244 return current_buffer
->mark
;
247 #if 0 /* this is now in lisp code */
248 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
249 "Set this buffer's mark to POS. Don't use this function!\n\
250 That is to say, don't use this function unless you want\n\
251 the user to see that the mark has moved, and you want the previous\n\
252 mark position to be lost.\n\
254 Normally, when a new mark is set, the old one should go on the stack.\n\
255 This is why most applications should use push-mark, not set-mark.\n\
257 Novice programmers often try to use the mark for the wrong purposes.\n\
258 The mark saves a location for the user's convenience.\n\
259 Most editing commands should not alter the mark.\n\
260 To remember a location for internal use in the Lisp program,\n\
261 store it in a Lisp variable. Example:\n\
263 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
269 current_buffer
->mark
= Qnil
;
272 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
274 if (NILP (current_buffer
->mark
))
275 current_buffer
->mark
= Fmake_marker ();
277 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
280 #endif /* commented-out code */
283 save_excursion_save ()
285 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
288 return Fcons (Fpoint_marker (),
289 Fcons (Fcopy_marker (current_buffer
->mark
),
290 Fcons (visible
? Qt
: Qnil
,
291 current_buffer
->mark_active
)));
295 save_excursion_restore (info
)
296 register Lisp_Object info
;
298 register Lisp_Object tem
, tem1
, omark
, nmark
;
300 tem
= Fmarker_buffer (Fcar (info
));
301 /* If buffer being returned to is now deleted, avoid error */
302 /* Otherwise could get error here while unwinding to top level
304 /* In that case, Fmarker_buffer returns nil now. */
310 unchain_marker (tem
);
311 tem
= Fcar (Fcdr (info
));
312 omark
= Fmarker_position (current_buffer
->mark
);
313 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
314 nmark
= Fmarker_position (tem
);
315 unchain_marker (tem
);
316 tem
= Fcdr (Fcdr (info
));
317 #if 0 /* We used to make the current buffer visible in the selected window
318 if that was true previously. That avoids some anomalies.
319 But it creates others, and it wasn't documented, and it is simpler
320 and cleaner never to alter the window/buffer connections. */
323 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
324 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
327 tem1
= current_buffer
->mark_active
;
328 current_buffer
->mark_active
= Fcdr (tem
);
329 if (!NILP (Vrun_hooks
))
331 /* If mark is active now, and either was not active
332 or was at a different place, run the activate hook. */
333 if (! NILP (current_buffer
->mark_active
))
335 if (! EQ (omark
, nmark
))
336 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
338 /* If mark has ceased to be active, run deactivate hook. */
339 else if (! NILP (tem1
))
340 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
345 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
346 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
347 Executes BODY just like `progn'.\n\
348 The values of point, mark and the current buffer are restored\n\
349 even in case of abnormal exit (throw or error).\n\
350 The state of activation of the mark is also restored.")
354 register Lisp_Object val
;
355 int count
= specpdl_ptr
- specpdl
;
357 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
360 return unbind_to (count
, val
);
363 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
364 "Return the number of characters in the current buffer.")
368 XFASTINT (temp
) = Z
- BEG
;
372 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
373 "Return the minimum permissible value of point in the current buffer.\n\
374 This is 1, unless narrowing (a buffer restriction) is in effect.")
378 XFASTINT (temp
) = BEGV
;
382 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
383 "Return a marker to the minimum permissible value of point in this buffer.\n\
384 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
387 return buildmark (BEGV
);
390 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
391 "Return the maximum permissible value of point in the current buffer.\n\
392 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
393 is in effect, in which case it is less.")
397 XFASTINT (temp
) = ZV
;
401 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
402 "Return a marker to the maximum permissible value of point in this buffer.\n\
403 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
404 is in effect, in which case it is less.")
407 return buildmark (ZV
);
410 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
411 "Return the character following point, as a number.\n\
412 At the end of the buffer or accessible region, return 0.")
419 XFASTINT (temp
) = FETCH_CHAR (point
);
423 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
424 "Return the character preceding point, as a number.\n\
425 At the beginning of the buffer or accessible region, return 0.")
432 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
436 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
437 "Return T if point is at the beginning of the buffer.\n\
438 If the buffer is narrowed, this means the beginning of the narrowed part.")
446 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
447 "Return T if point is at the end of the buffer.\n\
448 If the buffer is narrowed, this means the end of the narrowed part.")
456 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
457 "Return T if point is at the beginning of a line.")
460 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
465 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
466 "Return T if point is at the end of a line.\n\
467 `End of a line' includes point being at the end of the buffer.")
470 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
475 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
476 "Return character in current buffer at position POS.\n\
477 POS is an integer or a buffer pointer.\n\
478 If POS is out of range, the value is nil.")
482 register Lisp_Object val
;
485 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
488 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
490 XFASTINT (val
) = FETCH_CHAR (n
);
494 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
495 "Return the name under which the user logged in, as a string.\n\
496 This is based on the effective uid, not the real uid.\n\
497 Also, if the environment variable LOGNAME or USER is set,\n\
498 that determines the value of this function.")
504 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
506 "Return the name of the user's real uid, as a string.\n\
507 This ignores the environment variables LOGNAME and USER, so it differs from\n\
508 `user-login-name' when running under `su'.")
511 return Vuser_real_name
;
514 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
515 "Return the effective uid of Emacs, as an integer.")
518 return make_number (geteuid ());
521 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
522 "Return the real uid of Emacs, as an integer.")
525 return make_number (getuid ());
528 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
529 "Return the full name of the user logged in, as a string.")
532 return Vuser_full_name
;
535 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
536 "Return the name of the machine you are running on, as a string.")
542 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
543 "Return the process ID of Emacs, as an integer.")
546 return make_number (getpid ());
549 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
550 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
551 The time is returned as a list of three integers. The first has the\n\
552 most significant 16 bits of the seconds, while the second has the\n\
553 least significant 16 bits. The third integer gives the microsecond\n\
556 The microsecond count is zero on systems that do not provide\n\
557 resolution finer than a second.")
561 Lisp_Object result
[3];
564 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
565 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
566 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
568 return Flist (3, result
);
573 lisp_time_argument (specified_time
, result
)
574 Lisp_Object specified_time
;
577 if (NILP (specified_time
))
578 return time (result
) != -1;
581 Lisp_Object high
, low
;
582 high
= Fcar (specified_time
);
583 CHECK_NUMBER (high
, 0);
584 low
= Fcdr (specified_time
);
585 if (XTYPE (low
) == Lisp_Cons
)
587 CHECK_NUMBER (low
, 0);
588 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
589 return *result
>> 16 == XINT (high
);
593 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
594 "Return the current time, as a human-readable string.\n\
595 Programs can use this function to decode a time,\n\
596 since the number of columns in each field is fixed.\n\
597 The format is `Sun Sep 16 01:03:52 1973'.\n\
598 If an argument is given, it specifies a time to format\n\
599 instead of the current time. The argument should have the form:\n\
602 (HIGH LOW . IGNORED).\n\
603 Thus, you can use times obtained from `current-time'\n\
604 and from `file-attributes'.")
606 Lisp_Object specified_time
;
612 if (! lisp_time_argument (specified_time
, &value
))
614 tem
= (char *) ctime (&value
);
616 strncpy (buf
, tem
, 24);
619 return build_string (buf
);
622 #define TM_YEAR_ORIGIN 1900
624 /* Yield A - B, measured in seconds. */
629 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
630 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
631 /* Some compilers can't handle this as a single return statement. */
633 /* difference in day of year */
634 a
->tm_yday
- b
->tm_yday
635 /* + intervening leap days */
636 + ((ay
>> 2) - (by
>> 2))
638 + ((ay
/100 >> 2) - (by
/100 >> 2))
639 /* + difference in years * 365 */
640 + (long)(ay
-by
) * 365
642 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
643 + (a
->tm_min
- b
->tm_min
))
644 + (a
->tm_sec
- b
->tm_sec
));
647 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
648 "Return the offset and name for the local time zone.\n\
649 This returns a list of the form (OFFSET NAME).\n\
650 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
651 A negative value means west of Greenwich.\n\
652 NAME is a string giving the name of the time zone.\n\
653 If an argument is given, it specifies when the time zone offset is determined\n\
654 instead of using the current time. The argument should have the form:\n\
657 (HIGH LOW . IGNORED).\n\
658 Thus, you can use times obtained from `current-time'\n\
659 and from `file-attributes'.\n\
661 Some operating systems cannot provide all this information to Emacs;\n\
662 in this case, `current-time-zone' returns a list containing nil for\n\
663 the data it can't find.")
665 Lisp_Object specified_time
;
670 if (lisp_time_argument (specified_time
, &value
)
671 && (t
= gmtime (&value
)) != 0)
677 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
678 t
= localtime (&value
);
679 offset
= difftm (t
, &gmt
);
684 #else /* not HAVE_TM_ZONE */
686 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
687 s
= tzname
[t
->tm_isdst
];
689 #endif /* not HAVE_TM_ZONE */
692 /* No local time zone name is available; use "+-NNNN" instead. */
693 int am
= (offset
< 0 ? -offset
: offset
) / 60;
694 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
697 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
700 return Fmake_list (2, Qnil
);
712 /* Callers passing one argument to Finsert need not gcpro the
713 argument "array", since the only element of the array will
714 not be used after calling insert or insert_from_string, so
715 we don't care if it gets trashed. */
717 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
718 "Insert the arguments, either strings or characters, at point.\n\
719 Point moves forward so that it ends up after the inserted text.\n\
720 Any other markers at the point of insertion remain before the text.")
723 register Lisp_Object
*args
;
726 register Lisp_Object tem
;
729 for (argnum
= 0; argnum
< nargs
; argnum
++)
733 if (XTYPE (tem
) == Lisp_Int
)
738 else if (XTYPE (tem
) == Lisp_String
)
740 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
744 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
752 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
754 "Insert the arguments at point, inheriting properties from adjoining text.\n\
755 Point moves forward so that it ends up after the inserted text.\n\
756 Any other markers at the point of insertion remain before the text.")
759 register Lisp_Object
*args
;
762 register Lisp_Object tem
;
765 for (argnum
= 0; argnum
< nargs
; argnum
++)
769 if (XTYPE (tem
) == Lisp_Int
)
774 else if (XTYPE (tem
) == Lisp_String
)
776 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
780 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
788 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
789 "Insert strings or characters at point, relocating markers after the text.\n\
790 Point moves forward so that it ends up after the inserted text.\n\
791 Any other markers at the point of insertion also end up after the text.")
794 register Lisp_Object
*args
;
797 register Lisp_Object tem
;
800 for (argnum
= 0; argnum
< nargs
; argnum
++)
804 if (XTYPE (tem
) == Lisp_Int
)
807 insert_before_markers (str
, 1);
809 else if (XTYPE (tem
) == Lisp_String
)
811 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
815 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
823 DEFUN ("insert-before-markers-and-inherit",
824 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
826 "Insert text at point, relocating markers and inheriting properties.\n\
827 Point moves forward so that it ends up after the inserted text.\n\
828 Any other markers at the point of insertion also end up after the text.")
831 register Lisp_Object
*args
;
834 register Lisp_Object tem
;
837 for (argnum
= 0; argnum
< nargs
; argnum
++)
841 if (XTYPE (tem
) == Lisp_Int
)
844 insert_before_markers (str
, 1);
846 else if (XTYPE (tem
) == Lisp_String
)
848 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
852 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
860 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
861 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
862 Point and all markers are affected as in the function `insert'.\n\
863 Both arguments are required.")
865 Lisp_Object chr
, count
;
867 register unsigned char *string
;
871 CHECK_NUMBER (chr
, 0);
872 CHECK_NUMBER (count
, 1);
877 strlen
= min (n
, 256);
878 string
= (unsigned char *) alloca (strlen
);
879 for (i
= 0; i
< strlen
; i
++)
880 string
[i
] = XFASTINT (chr
);
883 insert (string
, strlen
);
892 /* Making strings from buffer contents. */
894 /* Return a Lisp_String containing the text of the current buffer from
895 START to END. If text properties are in use and the current buffer
896 has properties in the range specified, the resulting string will also
899 We don't want to use plain old make_string here, because it calls
900 make_uninit_string, which can cause the buffer arena to be
901 compacted. make_string has no way of knowing that the data has
902 been moved, and thus copies the wrong data into the string. This
903 doesn't effect most of the other users of make_string, so it should
904 be left as is. But we should use this function when conjuring
905 buffer substrings. */
908 make_buffer_string (start
, end
)
911 Lisp_Object result
, tem
, tem1
;
913 if (start
< GPT
&& GPT
< end
)
916 result
= make_uninit_string (end
- start
);
917 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
919 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
920 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
922 #ifdef USE_TEXT_PROPERTIES
923 if (XINT (tem
) != end
|| !NILP (tem1
))
924 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
930 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
931 "Return the contents of part of the current buffer as a string.\n\
932 The two arguments START and END are character positions;\n\
933 they can be in either order.")
937 register int beg
, end
;
939 validate_region (&b
, &e
);
943 return make_buffer_string (beg
, end
);
946 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
947 "Return the contents of the current buffer as a string.")
950 return make_buffer_string (BEGV
, ZV
);
953 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
955 "Insert before point a substring of the contents of buffer BUFFER.\n\
956 BUFFER may be a buffer or a buffer name.\n\
957 Arguments START and END are character numbers specifying the substring.\n\
958 They default to the beginning and the end of BUFFER.")
960 Lisp_Object buf
, b
, e
;
962 register int beg
, end
, temp
, len
, opoint
, start
;
963 register struct buffer
*bp
;
966 buffer
= Fget_buffer (buf
);
969 bp
= XBUFFER (buffer
);
975 CHECK_NUMBER_COERCE_MARKER (b
, 0);
982 CHECK_NUMBER_COERCE_MARKER (e
, 1);
987 temp
= beg
, beg
= end
, end
= temp
;
989 /* Move the gap or create enough gap in the current buffer. */
993 if (GAP_SIZE
< end
- beg
)
994 make_gap (end
- beg
- GAP_SIZE
);
1000 if (!(BUF_BEGV (bp
) <= beg
1002 && end
<= BUF_ZV (bp
)))
1003 args_out_of_range (b
, e
);
1005 /* Now the actual insertion will not do any gap motion,
1006 so it matters not if BUF is the current buffer. */
1007 if (beg
< BUF_GPT (bp
))
1009 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
1010 beg
= min (end
, BUF_GPT (bp
));
1013 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1015 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1016 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1017 opoint
, len
, current_buffer
, 0);
1022 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1024 "Compare two substrings of two buffers; return result as number.\n\
1025 the value is -N if first string is less after N-1 chars,\n\
1026 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1027 Each substring is represented as three arguments: BUFFER, START and END.\n\
1028 That makes six args in all, three for each substring.\n\n\
1029 The value of `case-fold-search' in the current buffer\n\
1030 determines whether case is significant or ignored.")
1031 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1032 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1034 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1035 register struct buffer
*bp1
, *bp2
;
1036 register unsigned char *trt
1037 = (!NILP (current_buffer
->case_fold_search
)
1038 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1040 /* Find the first buffer and its substring. */
1043 bp1
= current_buffer
;
1047 buf1
= Fget_buffer (buffer1
);
1050 bp1
= XBUFFER (buf1
);
1054 begp1
= BUF_BEGV (bp1
);
1057 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1058 begp1
= XINT (start1
);
1061 endp1
= BUF_ZV (bp1
);
1064 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1065 endp1
= XINT (end1
);
1069 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1071 if (!(BUF_BEGV (bp1
) <= begp1
1073 && endp1
<= BUF_ZV (bp1
)))
1074 args_out_of_range (start1
, end1
);
1076 /* Likewise for second substring. */
1079 bp2
= current_buffer
;
1083 buf2
= Fget_buffer (buffer2
);
1086 bp2
= XBUFFER (buffer2
);
1090 begp2
= BUF_BEGV (bp2
);
1093 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1094 begp2
= XINT (start2
);
1097 endp2
= BUF_ZV (bp2
);
1100 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1101 endp2
= XINT (end2
);
1105 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1107 if (!(BUF_BEGV (bp2
) <= begp2
1109 && endp2
<= BUF_ZV (bp2
)))
1110 args_out_of_range (start2
, end2
);
1112 len1
= endp1
- begp1
;
1113 len2
= endp2
- begp2
;
1118 for (i
= 0; i
< length
; i
++)
1120 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1121 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1128 return make_number (- 1 - i
);
1130 return make_number (i
+ 1);
1133 /* The strings match as far as they go.
1134 If one is shorter, that one is less. */
1136 return make_number (length
+ 1);
1137 else if (length
< len2
)
1138 return make_number (- length
- 1);
1140 /* Same length too => they are equal. */
1141 return make_number (0);
1144 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1145 Ssubst_char_in_region
, 4, 5, 0,
1146 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1147 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1148 and don't mark the buffer as really changed.")
1149 (start
, end
, fromchar
, tochar
, noundo
)
1150 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1152 register int pos
, stop
, look
;
1155 validate_region (&start
, &end
);
1156 CHECK_NUMBER (fromchar
, 2);
1157 CHECK_NUMBER (tochar
, 3);
1161 look
= XINT (fromchar
);
1165 if (FETCH_CHAR (pos
) == look
)
1169 modify_region (current_buffer
, XINT (start
), stop
);
1171 if (! NILP (noundo
))
1173 if (MODIFF
- 1 == current_buffer
->save_modified
)
1174 current_buffer
->save_modified
++;
1175 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1176 current_buffer
->auto_save_modified
++;
1183 record_change (pos
, 1);
1184 FETCH_CHAR (pos
) = XINT (tochar
);
1190 signal_after_change (XINT (start
),
1191 stop
- XINT (start
), stop
- XINT (start
));
1196 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1197 "From START to END, translate characters according to TABLE.\n\
1198 TABLE is a string; the Nth character in it is the mapping\n\
1199 for the character with code N. Returns the number of characters changed.")
1203 register Lisp_Object table
;
1205 register int pos
, stop
; /* Limits of the region. */
1206 register unsigned char *tt
; /* Trans table. */
1207 register int oc
; /* Old character. */
1208 register int nc
; /* New character. */
1209 int cnt
; /* Number of changes made. */
1210 Lisp_Object z
; /* Return. */
1211 int size
; /* Size of translate table. */
1213 validate_region (&start
, &end
);
1214 CHECK_STRING (table
, 2);
1216 size
= XSTRING (table
)->size
;
1217 tt
= XSTRING (table
)->data
;
1221 modify_region (current_buffer
, pos
, stop
);
1224 for (; pos
< stop
; ++pos
)
1226 oc
= FETCH_CHAR (pos
);
1232 record_change (pos
, 1);
1233 FETCH_CHAR (pos
) = nc
;
1234 signal_after_change (pos
, 1, 1);
1244 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1245 "Delete the text between point and mark.\n\
1246 When called from a program, expects two arguments,\n\
1247 positions (integers or markers) specifying the stretch to be deleted.")
1251 validate_region (&b
, &e
);
1252 del_range (XINT (b
), XINT (e
));
1256 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1257 "Remove restrictions (narrowing) from current buffer.\n\
1258 This allows the buffer's full text to be seen and edited.")
1262 SET_BUF_ZV (current_buffer
, Z
);
1264 /* Changing the buffer bounds invalidates any recorded current column. */
1265 invalidate_current_column ();
1269 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1270 "Restrict editing in this buffer to the current region.\n\
1271 The rest of the text becomes temporarily invisible and untouchable\n\
1272 but is not deleted; if you save the buffer in a file, the invisible\n\
1273 text is included in the file. \\[widen] makes all visible again.\n\
1274 See also `save-restriction'.\n\
1276 When calling from a program, pass two arguments; positions (integers\n\
1277 or markers) bounding the text that should remain visible.")
1279 register Lisp_Object b
, e
;
1283 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1284 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1286 if (XINT (b
) > XINT (e
))
1293 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1294 args_out_of_range (b
, e
);
1296 BEGV
= XFASTINT (b
);
1297 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1298 if (point
< XFASTINT (b
))
1299 SET_PT (XFASTINT (b
));
1300 if (point
> XFASTINT (e
))
1301 SET_PT (XFASTINT (e
));
1303 /* Changing the buffer bounds invalidates any recorded current column. */
1304 invalidate_current_column ();
1309 save_restriction_save ()
1311 register Lisp_Object bottom
, top
;
1312 /* Note: I tried using markers here, but it does not win
1313 because insertion at the end of the saved region
1314 does not advance mh and is considered "outside" the saved region. */
1315 XFASTINT (bottom
) = BEGV
- BEG
;
1316 XFASTINT (top
) = Z
- ZV
;
1318 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1322 save_restriction_restore (data
)
1325 register struct buffer
*buf
;
1326 register int newhead
, newtail
;
1327 register Lisp_Object tem
;
1329 buf
= XBUFFER (XCONS (data
)->car
);
1331 data
= XCONS (data
)->cdr
;
1333 tem
= XCONS (data
)->car
;
1334 newhead
= XINT (tem
);
1335 tem
= XCONS (data
)->cdr
;
1336 newtail
= XINT (tem
);
1337 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1342 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1343 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1346 /* If point is outside the new visible range, move it inside. */
1348 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1353 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1354 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1355 The buffer's restrictions make parts of the beginning and end invisible.\n\
1356 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1357 This special form, `save-restriction', saves the current buffer's restrictions\n\
1358 when it is entered, and restores them when it is exited.\n\
1359 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1360 The old restrictions settings are restored\n\
1361 even in case of abnormal exit (throw or error).\n\
1363 The value returned is the value of the last form in BODY.\n\
1365 `save-restriction' can get confused if, within the BODY, you widen\n\
1366 and then make changes outside the area within the saved restrictions.\n\
1368 Note: if you are using both `save-excursion' and `save-restriction',\n\
1369 use `save-excursion' outermost:\n\
1370 (save-excursion (save-restriction ...))")
1374 register Lisp_Object val
;
1375 int count
= specpdl_ptr
- specpdl
;
1377 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1378 val
= Fprogn (body
);
1379 return unbind_to (count
, val
);
1382 /* Buffer for the most recent text displayed by Fmessage. */
1383 static char *message_text
;
1385 /* Allocated length of that buffer. */
1386 static int message_length
;
1388 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1389 "Print a one-line message at the bottom of the screen.\n\
1390 The first argument is a control string.\n\
1391 It may contain %s or %d or %c to print successive following arguments.\n\
1392 %s means print an argument as a string, %d means print as number in decimal,\n\
1393 %c means print a number as a single character.\n\
1394 The argument used by %s must be a string or a symbol;\n\
1395 the argument used by %d or %c must be a number.\n\
1396 If the first argument is nil, clear any existing message; let the\n\
1397 minibuffer contents show.")
1409 register Lisp_Object val
;
1410 val
= Fformat (nargs
, args
);
1411 /* Copy the data so that it won't move when we GC. */
1414 message_text
= (char *)xmalloc (80);
1415 message_length
= 80;
1417 if (XSTRING (val
)->size
> message_length
)
1419 message_length
= XSTRING (val
)->size
;
1420 message_text
= (char *)xrealloc (message_text
, message_length
);
1422 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1423 message2 (message_text
, XSTRING (val
)->size
);
1428 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1429 "Format a string out of a control-string and arguments.\n\
1430 The first argument is a control string.\n\
1431 The other arguments are substituted into it to make the result, a string.\n\
1432 It may contain %-sequences meaning to substitute the next argument.\n\
1433 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1434 %d means print as number in decimal (%o octal, %x hex).\n\
1435 %c means print a number as a single character.\n\
1436 %S means print any object as an s-expression (using prin1).\n\
1437 The argument used for %d, %o, %x or %c must be a number.\n\
1438 Use %% to put a single % into the output.")
1441 register Lisp_Object
*args
;
1443 register int n
; /* The number of the next arg to substitute */
1444 register int total
= 5; /* An estimate of the final length */
1446 register unsigned char *format
, *end
;
1448 extern char *index ();
1449 /* It should not be necessary to GCPRO ARGS, because
1450 the caller in the interpreter should take care of that. */
1452 CHECK_STRING (args
[0], 0);
1453 format
= XSTRING (args
[0])->data
;
1454 end
= format
+ XSTRING (args
[0])->size
;
1457 while (format
!= end
)
1458 if (*format
++ == '%')
1462 /* Process a numeric arg and skip it. */
1463 minlen
= atoi (format
);
1468 while ((*format
>= '0' && *format
<= '9')
1469 || *format
== '-' || *format
== ' ' || *format
== '.')
1474 else if (++n
>= nargs
)
1475 error ("not enough arguments for format string");
1476 else if (*format
== 'S')
1478 /* For `S', prin1 the argument and then treat like a string. */
1479 register Lisp_Object tem
;
1480 tem
= Fprin1_to_string (args
[n
], Qnil
);
1484 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1486 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1489 else if (XTYPE (args
[n
]) == Lisp_String
)
1492 if (*format
!= 's' && *format
!= 'S')
1493 error ("format specifier doesn't match argument type");
1494 total
+= XSTRING (args
[n
])->size
;
1496 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1497 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1499 #ifdef LISP_FLOAT_TYPE
1500 /* The following loop assumes the Lisp type indicates
1501 the proper way to pass the argument.
1502 So make sure we have a flonum if the argument should
1504 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1505 args
[n
] = Ffloat (args
[n
]);
1509 #ifdef LISP_FLOAT_TYPE
1510 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1512 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1513 args
[n
] = Ftruncate (args
[n
]);
1519 /* Anything but a string, convert to a string using princ. */
1520 register Lisp_Object tem
;
1521 tem
= Fprin1_to_string (args
[n
], Qt
);
1528 register int nstrings
= n
+ 1;
1530 /* Allocate twice as many strings as we have %-escapes; floats occupy
1531 two slots, and we're not sure how many of those we have. */
1532 register unsigned char **strings
1533 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1537 for (n
= 0; n
< nstrings
; n
++)
1540 strings
[i
++] = (unsigned char *) "";
1541 else if (XTYPE (args
[n
]) == Lisp_Int
)
1542 /* We checked above that the corresponding format effector
1543 isn't %s, which would cause MPV. */
1544 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1545 #ifdef LISP_FLOAT_TYPE
1546 else if (XTYPE (args
[n
]) == Lisp_Float
)
1548 union { double d
; int half
[2]; } u
;
1550 u
.d
= XFLOAT (args
[n
])->data
;
1551 strings
[i
++] = (unsigned char *) u
.half
[0];
1552 strings
[i
++] = (unsigned char *) u
.half
[1];
1556 strings
[i
++] = XSTRING (args
[n
])->data
;
1559 /* Format it in bigger and bigger buf's until it all fits. */
1562 buf
= (char *) alloca (total
+ 1);
1565 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1566 if (buf
[total
- 1] == 0)
1574 return make_string (buf
, length
);
1580 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1581 int arg0
, arg1
, arg2
, arg3
, arg4
;
1595 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1597 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1599 return build_string (buf
);
1602 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1603 "Return t if two characters match, optionally ignoring case.\n\
1604 Both arguments must be characters (i.e. integers).\n\
1605 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1607 register Lisp_Object c1
, c2
;
1609 unsigned char *downcase
= DOWNCASE_TABLE
;
1610 CHECK_NUMBER (c1
, 0);
1611 CHECK_NUMBER (c2
, 1);
1613 if (!NILP (current_buffer
->case_fold_search
)
1614 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1615 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1616 : XINT (c1
) == XINT (c2
))
1621 /* Transpose the markers in two regions of the current buffer, and
1622 adjust the ones between them if necessary (i.e.: if the regions
1625 Traverses the entire marker list of the buffer to do so, adding an
1626 appropriate amount to some, subtracting from some, and leaving the
1627 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1629 It's caller's job to see that (start1 <= end1 <= start2 <= end2),
1630 and that the buffer gap will not conflict with the markers. This
1631 last requirement is odd and maybe should be taken out, but it works
1632 for now because Ftranspose_regions does in fact guarantee that, in
1633 addition to providing universal health-care coverage. */
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
;
1641 register struct Lisp_Marker
*m
;
1643 /* Internally, marker positions take the gap into account, so if the
1644 * gap is before one or both of the regions, the region's limits
1645 * must be adjusted to compensate. The caller guaranteed that the
1646 * gap is not inside any of the regions, however, so this is fairly
1651 register int gs
= GAP_SIZE
;
1652 start1
+= gs
; end1
+= gs
;
1653 start2
+= gs
; end2
+= gs
;
1655 else if (GPT
< start2
)
1657 /* If the regions are of equal size, the gap could, in theory,
1658 * be somewhere between them. */
1659 register int gs
= GAP_SIZE
;
1660 start2
+= gs
; end2
+= gs
;
1663 /* The difference between the region's lengths */
1664 diff
= (end2
- start2
) - (end1
- start1
);
1666 /* For shifting each marker in a region by the length of the other
1667 * region plus the distance between the regions.
1669 amt1
= (end2
- start2
) + (start2
- end1
);
1670 amt2
= (end1
- start1
) + (start2
- end1
);
1672 marker
= current_buffer
->markers
;
1674 while (!NILP (marker
))
1676 m
= XMARKER (marker
);
1678 if (mpos
>= start1
&& mpos
< end1
) /* in region 1 */
1682 else if (mpos
>= start2
&& mpos
< end2
) /* in region 2 */
1686 else if (mpos
>= end1
&& mpos
< start2
) /* between the regions */
1694 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1695 "Transpose region START1 to END1 with START2 to END2.\n\
1696 The regions may not be overlapping, because the size of the buffer is\n\
1697 never changed in a transposition.\n\
1699 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1700 any markers that happen to be located in the regions.\n\
1702 Transposing beyond buffer boundaries is an error.")
1703 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1704 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1706 register int start1
, end1
, start2
, end2
,
1707 gap
, len1
, len_mid
, len2
;
1708 unsigned char *start1_addr
, *start2_addr
, *temp
;
1710 #ifdef USE_TEXT_PROPERTIES
1711 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1712 cur_intv
= current_buffer
->intervals
;
1713 #endif /* USE_TEXT_PROPERTIES */
1715 validate_region (&startr1
, &endr1
);
1716 validate_region (&startr2
, &endr2
);
1718 start1
= XFASTINT (startr1
);
1719 end1
= XFASTINT (endr1
);
1720 start2
= XFASTINT (startr2
);
1721 end2
= XFASTINT (endr2
);
1724 /* Swap the regions if they're reversed. */
1727 register int glumph
= start1
;
1735 len1
= end1
- start1
;
1736 len2
= end2
- start2
;
1739 error ("transposed regions not properly ordered");
1740 else if (start1
== end1
|| start2
== end2
)
1741 error ("transposed region may not be of length 0");
1743 /* The possibilities are:
1744 1. Adjacent (contiguous) regions, or separate but equal regions
1745 (no, really equal, in this case!), or
1746 2. Separate regions of unequal size.
1748 The worst case is usually No. 2. It means that (aside from
1749 potential need for getting the gap out of the way), there also
1750 needs to be a shifting of the text between the two regions. So
1751 if they are spread far apart, we are that much slower... sigh. */
1753 /* It must be pointed out that the really studly thing to do would
1754 be not to move the gap at all, but to leave it in place and work
1755 around it if necessary. This would be extremely efficient,
1756 especially considering that people are likely to do
1757 transpositions near where they are working interactively, which
1758 is exactly where the gap would be found. However, such code
1759 would be much harder to write and to read. So, if you are
1760 reading this comment and are feeling squirrely, by all means have
1761 a go! I just didn't feel like doing it, so I will simply move
1762 the gap the minimum distance to get it out of the way, and then
1763 deal with an unbroken array. */
1765 /* Make sure the gap won't interfere, by moving it out of the text
1766 we will operate on. */
1767 if (start1
< gap
&& gap
< end2
)
1769 if (gap
- start1
< end2
- gap
)
1775 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1776 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1778 /* Hmmm... how about checking to see if the gap is large
1779 enough to use as the temporary storage? That would avoid an
1780 allocation... interesting. Later, don't fool with it now. */
1782 /* Working without memmove, for portability (sigh), so must be
1783 careful of overlapping subsections of the array... */
1785 if (end1
== start2
) /* adjacent regions */
1787 modify_region (current_buffer
, start1
, end2
);
1788 record_change (start1
, len1
+ len2
);
1790 #ifdef USE_TEXT_PROPERTIES
1791 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1792 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1793 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1794 #endif /* USE_TEXT_PROPERTIES */
1796 /* First region smaller than second. */
1799 /* We use alloca only if it is small,
1800 because we want to avoid stack overflow. */
1802 temp
= (unsigned char *) xmalloc (len2
);
1804 temp
= (unsigned char *) alloca (len2
);
1805 bcopy (start2_addr
, temp
, len2
);
1806 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1807 bcopy (temp
, start1_addr
, len2
);
1812 /* First region not smaller than second. */
1815 temp
= (unsigned char *) xmalloc (len1
);
1817 temp
= (unsigned char *) alloca (len1
);
1818 bcopy (start1_addr
, temp
, len1
);
1819 bcopy (start2_addr
, start1_addr
, len2
);
1820 bcopy (temp
, start1_addr
+ len2
, len1
);
1824 #ifdef USE_TEXT_PROPERTIES
1825 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1826 len1
, current_buffer
, 0);
1827 graft_intervals_into_buffer (tmp_interval2
, start1
,
1828 len2
, current_buffer
, 0);
1829 #endif /* USE_TEXT_PROPERTIES */
1831 /* Non-adjacent regions, because end1 != start2, bleagh... */
1835 /* Regions are same size, though, how nice. */
1837 modify_region (current_buffer
, start1
, end1
);
1838 modify_region (current_buffer
, start2
, end2
);
1839 record_change (start1
, len1
);
1840 record_change (start2
, len2
);
1841 #ifdef USE_TEXT_PROPERTIES
1842 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1843 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1844 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
1845 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
1846 #endif /* USE_TEXT_PROPERTIES */
1849 temp
= (unsigned char *) xmalloc (len1
);
1851 temp
= (unsigned char *) alloca (len1
);
1852 bcopy (start1_addr
, temp
, len1
);
1853 bcopy (start2_addr
, start1_addr
, len2
);
1854 bcopy (temp
, start2_addr
, len1
);
1857 #ifdef USE_TEXT_PROPERTIES
1858 graft_intervals_into_buffer (tmp_interval1
, start2
,
1859 len1
, current_buffer
, 0);
1860 graft_intervals_into_buffer (tmp_interval2
, start1
,
1861 len2
, current_buffer
, 0);
1862 #endif /* USE_TEXT_PROPERTIES */
1865 else if (len1
< len2
) /* Second region larger than first */
1866 /* Non-adjacent & unequal size, area between must also be shifted. */
1868 len_mid
= start2
- end1
;
1869 modify_region (current_buffer
, start1
, end2
);
1870 record_change (start1
, (end2
- start1
));
1871 #ifdef USE_TEXT_PROPERTIES
1872 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1873 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1874 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1875 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1876 #endif /* USE_TEXT_PROPERTIES */
1878 /* holds region 2 */
1880 temp
= (unsigned char *) xmalloc (len2
);
1882 temp
= (unsigned char *) alloca (len2
);
1883 bcopy (start2_addr
, temp
, len2
);
1884 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
1885 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
1886 bcopy (temp
, start1_addr
, len2
);
1889 #ifdef USE_TEXT_PROPERTIES
1890 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
1891 len1
, current_buffer
, 0);
1892 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
1893 len_mid
, current_buffer
, 0);
1894 graft_intervals_into_buffer (tmp_interval2
, start1
,
1895 len2
, current_buffer
, 0);
1896 #endif /* USE_TEXT_PROPERTIES */
1899 /* Second region smaller than first. */
1901 len_mid
= start2
- end1
;
1902 record_change (start1
, (end2
- start1
));
1903 modify_region (current_buffer
, start1
, end2
);
1905 #ifdef USE_TEXT_PROPERTIES
1906 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1907 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
1908 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1909 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1910 #endif /* USE_TEXT_PROPERTIES */
1912 /* holds region 1 */
1914 temp
= (unsigned char *) xmalloc (len1
);
1916 temp
= (unsigned char *) alloca (len1
);
1917 bcopy (start1_addr
, temp
, len1
);
1918 bcopy (start2_addr
, start1_addr
, len2
);
1919 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
1920 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
1923 #ifdef USE_TEXT_PROPERTIES
1924 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
1925 len1
, current_buffer
, 0);
1926 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
1927 len_mid
, current_buffer
, 0);
1928 graft_intervals_into_buffer (tmp_interval2
, start1
,
1929 len2
, current_buffer
, 0);
1930 #endif /* USE_TEXT_PROPERTIES */
1934 /* todo: this will be slow, because for every transposition, we
1935 traverse the whole friggin marker list. Possible solutions:
1936 somehow get a list of *all* the markers across multiple
1937 transpositions and do it all in one swell phoop. Or maybe modify
1938 Emacs' marker code to keep an ordered list or tree. This might
1939 be nicer, and more beneficial in the long run, but would be a
1940 bunch of work. Plus the way they're arranged now is nice. */
1941 if (NILP (leave_markers
))
1942 transpose_markers (start1
, end1
, start2
, end2
);
1951 staticpro (&Vuser_name
);
1952 staticpro (&Vuser_full_name
);
1953 staticpro (&Vuser_real_name
);
1954 staticpro (&Vsystem_name
);
1956 defsubr (&Schar_equal
);
1957 defsubr (&Sgoto_char
);
1958 defsubr (&Sstring_to_char
);
1959 defsubr (&Schar_to_string
);
1960 defsubr (&Sbuffer_substring
);
1961 defsubr (&Sbuffer_string
);
1963 defsubr (&Spoint_marker
);
1964 defsubr (&Smark_marker
);
1966 defsubr (&Sregion_beginning
);
1967 defsubr (&Sregion_end
);
1968 /* defsubr (&Smark); */
1969 /* defsubr (&Sset_mark); */
1970 defsubr (&Ssave_excursion
);
1972 defsubr (&Sbufsize
);
1973 defsubr (&Spoint_max
);
1974 defsubr (&Spoint_min
);
1975 defsubr (&Spoint_min_marker
);
1976 defsubr (&Spoint_max_marker
);
1982 defsubr (&Sfollowing_char
);
1983 defsubr (&Sprevious_char
);
1984 defsubr (&Schar_after
);
1986 defsubr (&Sinsert_before_markers
);
1987 defsubr (&Sinsert_and_inherit
);
1988 defsubr (&Sinsert_and_inherit_before_markers
);
1989 defsubr (&Sinsert_char
);
1991 defsubr (&Suser_login_name
);
1992 defsubr (&Suser_real_login_name
);
1993 defsubr (&Suser_uid
);
1994 defsubr (&Suser_real_uid
);
1995 defsubr (&Suser_full_name
);
1996 defsubr (&Semacs_pid
);
1997 defsubr (&Scurrent_time
);
1998 defsubr (&Scurrent_time_string
);
1999 defsubr (&Scurrent_time_zone
);
2000 defsubr (&Ssystem_name
);
2001 defsubr (&Smessage
);
2004 defsubr (&Sinsert_buffer_substring
);
2005 defsubr (&Scompare_buffer_substrings
);
2006 defsubr (&Ssubst_char_in_region
);
2007 defsubr (&Stranslate_region
);
2008 defsubr (&Sdelete_region
);
2010 defsubr (&Snarrow_to_region
);
2011 defsubr (&Ssave_restriction
);
2012 defsubr (&Stranspose_regions
);