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 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
564 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
565 XSETINT (result
[2], 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
);
586 CHECK_NUMBER (low
, 0);
587 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
588 return *result
>> 16 == XINT (high
);
592 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 2, 2, 0,
593 "Use FORMAT-STRING to format the time TIME.\n\
594 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from\n\
595 `current-time' and `file-attributes'.\n\
596 FORMAT-STRING may contain %-sequences to substitute parts of the time.\n\
597 %a is replaced by the abbreviated name of the day of week.\n\
598 %A is replaced by the full name of the day of week.\n\
599 %b is replaced by the abbreviated name of the month.\n\
600 %B is replaced by the full name of the month.\n\
601 %c is a synonym for \"%x %X\".\n\
602 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.\n\
603 %d is replaced by the day of month, zero-padded.\n\
604 %D is a synonym for \"%m/%d/%y\".\n\
605 %e is replaced by the day of month, blank-padded.\n\
606 %h is a synonym for \"%b\".\n\
607 %H is replaced by the hour (00-23).\n\
608 %I is replaced by the hour (00-12).\n\
609 %j is replaced by the day of the year (001-366).\n\
610 %k is replaced by the hour (0-23), blank padded.\n\
611 %l is replaced by the hour (1-12), blank padded.\n\
612 %m is replaced by the month (01-12).\n\
613 %M is replaced by the minut (00-59).\n\
614 %n is a synonym for \"\\n\".\n\
615 %p is replaced by AM or PM, as appropriate.\n\
616 %r is a synonym for \"%I:%M:%S %p\".\n\
617 %R is a synonym for \"%H:%M\".\n\
618 %S is replaced by the seconds (00-60).\n\
619 %t is a synonym for \"\\t\".\n\
620 %T is a synonym for \"%H:%M:%S\".\n\
621 %U is replaced by the week of the year (01-52), first day of week is Sunday.\n\
622 %w is replaced by the day of week (0-6), Sunday is day 0.\n\
623 %W is replaced by the week of the year (01-52), first day of week is Monday.\n\
624 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.\n\
625 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.\n\
626 %y is replaced by the year without century (00-99).\n\
627 %Y is replaced by the year with century.\n\
628 %Z is replaced by the time zone abbreviation.\n\
630 The number of options reflects the strftime(3) function.")
631 (format_string
, time
)
632 Lisp_Object format_string
, time
;
637 CHECK_STRING (format_string
, 1);
639 if (! lisp_time_argument (time
, &value
))
640 error ("Invalid time specification");
642 /* This is probably enough. */
643 size
= XSTRING (format_string
)->size
* 6 + 50;
647 char *buf
= (char *) alloca (size
);
648 if (strftime (buf
, size
, XSTRING (format_string
)->data
,
650 return build_string (buf
);
651 /* If buffer was too small, make it bigger. */
656 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
657 "Return the current time, as a human-readable string.\n\
658 Programs can use this function to decode a time,\n\
659 since the number of columns in each field is fixed.\n\
660 The format is `Sun Sep 16 01:03:52 1973'.\n\
661 If an argument is given, it specifies a time to format\n\
662 instead of the current time. The argument should have the form:\n\
665 (HIGH LOW . IGNORED).\n\
666 Thus, you can use times obtained from `current-time'\n\
667 and from `file-attributes'.")
669 Lisp_Object specified_time
;
675 if (! lisp_time_argument (specified_time
, &value
))
677 tem
= (char *) ctime (&value
);
679 strncpy (buf
, tem
, 24);
682 return build_string (buf
);
685 #define TM_YEAR_ORIGIN 1900
687 /* Yield A - B, measured in seconds. */
692 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
693 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
694 /* Some compilers can't handle this as a single return statement. */
696 /* difference in day of year */
697 a
->tm_yday
- b
->tm_yday
698 /* + intervening leap days */
699 + ((ay
>> 2) - (by
>> 2))
701 + ((ay
/100 >> 2) - (by
/100 >> 2))
702 /* + difference in years * 365 */
703 + (long)(ay
-by
) * 365
705 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
706 + (a
->tm_min
- b
->tm_min
))
707 + (a
->tm_sec
- b
->tm_sec
));
710 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
711 "Return the offset and name for the local time zone.\n\
712 This returns a list of the form (OFFSET NAME).\n\
713 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
714 A negative value means west of Greenwich.\n\
715 NAME is a string giving the name of the time zone.\n\
716 If an argument is given, it specifies when the time zone offset is determined\n\
717 instead of using the current time. The argument should have the form:\n\
720 (HIGH LOW . IGNORED).\n\
721 Thus, you can use times obtained from `current-time'\n\
722 and from `file-attributes'.\n\
724 Some operating systems cannot provide all this information to Emacs;\n\
725 in this case, `current-time-zone' returns a list containing nil for\n\
726 the data it can't find.")
728 Lisp_Object specified_time
;
733 if (lisp_time_argument (specified_time
, &value
)
734 && (t
= gmtime (&value
)) != 0)
740 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
741 t
= localtime (&value
);
742 offset
= difftm (t
, &gmt
);
746 s
= (char *)t
->tm_zone
;
747 #else /* not HAVE_TM_ZONE */
749 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
750 s
= tzname
[t
->tm_isdst
];
752 #endif /* not HAVE_TM_ZONE */
755 /* No local time zone name is available; use "+-NNNN" instead. */
756 int am
= (offset
< 0 ? -offset
: offset
) / 60;
757 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
760 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
763 return Fmake_list (2, Qnil
);
775 /* Callers passing one argument to Finsert need not gcpro the
776 argument "array", since the only element of the array will
777 not be used after calling insert or insert_from_string, so
778 we don't care if it gets trashed. */
780 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
781 "Insert the arguments, either strings or characters, at point.\n\
782 Point moves forward so that it ends up after the inserted text.\n\
783 Any other markers at the point of insertion remain before the text.")
786 register Lisp_Object
*args
;
789 register Lisp_Object tem
;
792 for (argnum
= 0; argnum
< nargs
; argnum
++)
801 else if (STRINGP (tem
))
803 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
807 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
815 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
817 "Insert the arguments at point, inheriting properties from adjoining text.\n\
818 Point moves forward so that it ends up after the inserted text.\n\
819 Any other markers at the point of insertion remain before the text.")
822 register Lisp_Object
*args
;
825 register Lisp_Object tem
;
828 for (argnum
= 0; argnum
< nargs
; argnum
++)
835 insert_and_inherit (str
, 1);
837 else if (STRINGP (tem
))
839 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
843 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
851 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
852 "Insert strings or characters at point, relocating markers after the text.\n\
853 Point moves forward so that it ends up after the inserted text.\n\
854 Any other markers at the point of insertion also end up after the text.")
857 register Lisp_Object
*args
;
860 register Lisp_Object tem
;
863 for (argnum
= 0; argnum
< nargs
; argnum
++)
870 insert_before_markers (str
, 1);
872 else if (STRINGP (tem
))
874 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
878 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
886 DEFUN ("insert-before-markers-and-inherit",
887 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
889 "Insert text at point, relocating markers and inheriting properties.\n\
890 Point moves forward so that it ends up after the inserted text.\n\
891 Any other markers at the point of insertion also end up after the text.")
894 register Lisp_Object
*args
;
897 register Lisp_Object tem
;
900 for (argnum
= 0; argnum
< nargs
; argnum
++)
907 insert_before_markers_and_inherit (str
, 1);
909 else if (STRINGP (tem
))
911 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
915 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
923 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
924 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
925 Point and all markers are affected as in the function `insert'.\n\
926 Both arguments are required.\n\
927 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
928 from adjoining text, if those properties are sticky.")
929 (chr
, count
, inherit
)
930 Lisp_Object chr
, count
, inherit
;
932 register unsigned char *string
;
936 CHECK_NUMBER (chr
, 0);
937 CHECK_NUMBER (count
, 1);
942 strlen
= min (n
, 256);
943 string
= (unsigned char *) alloca (strlen
);
944 for (i
= 0; i
< strlen
; i
++)
945 string
[i
] = XFASTINT (chr
);
949 insert_and_inherit (string
, strlen
);
951 insert (string
, strlen
);
960 /* Making strings from buffer contents. */
962 /* Return a Lisp_String containing the text of the current buffer from
963 START to END. If text properties are in use and the current buffer
964 has properties in the range specified, the resulting string will also
967 We don't want to use plain old make_string here, because it calls
968 make_uninit_string, which can cause the buffer arena to be
969 compacted. make_string has no way of knowing that the data has
970 been moved, and thus copies the wrong data into the string. This
971 doesn't effect most of the other users of make_string, so it should
972 be left as is. But we should use this function when conjuring
973 buffer substrings. */
976 make_buffer_string (start
, end
)
979 Lisp_Object result
, tem
, tem1
;
981 if (start
< GPT
&& GPT
< end
)
984 result
= make_uninit_string (end
- start
);
985 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
987 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
988 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
990 #ifdef USE_TEXT_PROPERTIES
991 if (XINT (tem
) != end
|| !NILP (tem1
))
992 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
998 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
999 "Return the contents of part of the current buffer as a string.\n\
1000 The two arguments START and END are character positions;\n\
1001 they can be in either order.")
1005 register int beg
, end
;
1007 validate_region (&b
, &e
);
1011 return make_buffer_string (beg
, end
);
1014 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1015 "Return the contents of the current buffer as a string.")
1018 return make_buffer_string (BEGV
, ZV
);
1021 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1023 "Insert before point a substring of the contents of buffer BUFFER.\n\
1024 BUFFER may be a buffer or a buffer name.\n\
1025 Arguments START and END are character numbers specifying the substring.\n\
1026 They default to the beginning and the end of BUFFER.")
1028 Lisp_Object buf
, b
, e
;
1030 register int beg
, end
, temp
, len
, opoint
, start
;
1031 register struct buffer
*bp
;
1034 buffer
= Fget_buffer (buf
);
1037 bp
= XBUFFER (buffer
);
1040 beg
= BUF_BEGV (bp
);
1043 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1050 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1055 temp
= beg
, beg
= end
, end
= temp
;
1057 /* Move the gap or create enough gap in the current buffer. */
1061 if (GAP_SIZE
< end
- beg
)
1062 make_gap (end
- beg
- GAP_SIZE
);
1068 if (!(BUF_BEGV (bp
) <= beg
1070 && end
<= BUF_ZV (bp
)))
1071 args_out_of_range (b
, e
);
1073 /* Now the actual insertion will not do any gap motion,
1074 so it matters not if BUF is the current buffer. */
1075 if (beg
< BUF_GPT (bp
))
1077 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
1078 beg
= min (end
, BUF_GPT (bp
));
1081 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1083 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1084 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1085 opoint
, len
, current_buffer
, 0);
1090 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1092 "Compare two substrings of two buffers; return result as number.\n\
1093 the value is -N if first string is less after N-1 chars,\n\
1094 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1095 Each substring is represented as three arguments: BUFFER, START and END.\n\
1096 That makes six args in all, three for each substring.\n\n\
1097 The value of `case-fold-search' in the current buffer\n\
1098 determines whether case is significant or ignored.")
1099 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1100 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1102 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1103 register struct buffer
*bp1
, *bp2
;
1104 register unsigned char *trt
1105 = (!NILP (current_buffer
->case_fold_search
)
1106 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1108 /* Find the first buffer and its substring. */
1111 bp1
= current_buffer
;
1115 buf1
= Fget_buffer (buffer1
);
1118 bp1
= XBUFFER (buf1
);
1122 begp1
= BUF_BEGV (bp1
);
1125 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1126 begp1
= XINT (start1
);
1129 endp1
= BUF_ZV (bp1
);
1132 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1133 endp1
= XINT (end1
);
1137 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1139 if (!(BUF_BEGV (bp1
) <= begp1
1141 && endp1
<= BUF_ZV (bp1
)))
1142 args_out_of_range (start1
, end1
);
1144 /* Likewise for second substring. */
1147 bp2
= current_buffer
;
1151 buf2
= Fget_buffer (buffer2
);
1154 bp2
= XBUFFER (buffer2
);
1158 begp2
= BUF_BEGV (bp2
);
1161 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1162 begp2
= XINT (start2
);
1165 endp2
= BUF_ZV (bp2
);
1168 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1169 endp2
= XINT (end2
);
1173 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1175 if (!(BUF_BEGV (bp2
) <= begp2
1177 && endp2
<= BUF_ZV (bp2
)))
1178 args_out_of_range (start2
, end2
);
1180 len1
= endp1
- begp1
;
1181 len2
= endp2
- begp2
;
1186 for (i
= 0; i
< length
; i
++)
1188 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1189 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1196 return make_number (- 1 - i
);
1198 return make_number (i
+ 1);
1201 /* The strings match as far as they go.
1202 If one is shorter, that one is less. */
1204 return make_number (length
+ 1);
1205 else if (length
< len2
)
1206 return make_number (- length
- 1);
1208 /* Same length too => they are equal. */
1209 return make_number (0);
1212 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1213 Ssubst_char_in_region
, 4, 5, 0,
1214 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1215 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1216 and don't mark the buffer as really changed.")
1217 (start
, end
, fromchar
, tochar
, noundo
)
1218 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1220 register int pos
, stop
, look
;
1223 validate_region (&start
, &end
);
1224 CHECK_NUMBER (fromchar
, 2);
1225 CHECK_NUMBER (tochar
, 3);
1229 look
= XINT (fromchar
);
1233 if (FETCH_CHAR (pos
) == look
)
1237 modify_region (current_buffer
, XINT (start
), stop
);
1239 if (! NILP (noundo
))
1241 if (MODIFF
- 1 == current_buffer
->save_modified
)
1242 current_buffer
->save_modified
++;
1243 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1244 current_buffer
->auto_save_modified
++;
1251 record_change (pos
, 1);
1252 FETCH_CHAR (pos
) = XINT (tochar
);
1258 signal_after_change (XINT (start
),
1259 stop
- XINT (start
), stop
- XINT (start
));
1264 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1265 "From START to END, translate characters according to TABLE.\n\
1266 TABLE is a string; the Nth character in it is the mapping\n\
1267 for the character with code N. Returns the number of characters changed.")
1271 register Lisp_Object table
;
1273 register int pos
, stop
; /* Limits of the region. */
1274 register unsigned char *tt
; /* Trans table. */
1275 register int oc
; /* Old character. */
1276 register int nc
; /* New character. */
1277 int cnt
; /* Number of changes made. */
1278 Lisp_Object z
; /* Return. */
1279 int size
; /* Size of translate table. */
1281 validate_region (&start
, &end
);
1282 CHECK_STRING (table
, 2);
1284 size
= XSTRING (table
)->size
;
1285 tt
= XSTRING (table
)->data
;
1289 modify_region (current_buffer
, pos
, stop
);
1292 for (; pos
< stop
; ++pos
)
1294 oc
= FETCH_CHAR (pos
);
1300 record_change (pos
, 1);
1301 FETCH_CHAR (pos
) = nc
;
1302 signal_after_change (pos
, 1, 1);
1312 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1313 "Delete the text between point and mark.\n\
1314 When called from a program, expects two arguments,\n\
1315 positions (integers or markers) specifying the stretch to be deleted.")
1319 validate_region (&b
, &e
);
1320 del_range (XINT (b
), XINT (e
));
1324 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1325 "Remove restrictions (narrowing) from current buffer.\n\
1326 This allows the buffer's full text to be seen and edited.")
1330 SET_BUF_ZV (current_buffer
, Z
);
1332 /* Changing the buffer bounds invalidates any recorded current column. */
1333 invalidate_current_column ();
1337 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1338 "Restrict editing in this buffer to the current region.\n\
1339 The rest of the text becomes temporarily invisible and untouchable\n\
1340 but is not deleted; if you save the buffer in a file, the invisible\n\
1341 text is included in the file. \\[widen] makes all visible again.\n\
1342 See also `save-restriction'.\n\
1344 When calling from a program, pass two arguments; positions (integers\n\
1345 or markers) bounding the text that should remain visible.")
1347 register Lisp_Object b
, e
;
1349 register EMACS_INT i
;
1351 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1352 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1354 if (XINT (b
) > XINT (e
))
1361 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1362 args_out_of_range (b
, e
);
1364 BEGV
= XFASTINT (b
);
1365 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1366 if (point
< XFASTINT (b
))
1367 SET_PT (XFASTINT (b
));
1368 if (point
> XFASTINT (e
))
1369 SET_PT (XFASTINT (e
));
1371 /* Changing the buffer bounds invalidates any recorded current column. */
1372 invalidate_current_column ();
1377 save_restriction_save ()
1379 register Lisp_Object bottom
, top
;
1380 /* Note: I tried using markers here, but it does not win
1381 because insertion at the end of the saved region
1382 does not advance mh and is considered "outside" the saved region. */
1383 XFASTINT (bottom
) = BEGV
- BEG
;
1384 XFASTINT (top
) = Z
- ZV
;
1386 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1390 save_restriction_restore (data
)
1393 register struct buffer
*buf
;
1394 register int newhead
, newtail
;
1395 register Lisp_Object tem
;
1397 buf
= XBUFFER (XCONS (data
)->car
);
1399 data
= XCONS (data
)->cdr
;
1401 tem
= XCONS (data
)->car
;
1402 newhead
= XINT (tem
);
1403 tem
= XCONS (data
)->cdr
;
1404 newtail
= XINT (tem
);
1405 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1410 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1411 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1414 /* If point is outside the new visible range, move it inside. */
1416 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1421 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1422 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1423 The buffer's restrictions make parts of the beginning and end invisible.\n\
1424 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1425 This special form, `save-restriction', saves the current buffer's restrictions\n\
1426 when it is entered, and restores them when it is exited.\n\
1427 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1428 The old restrictions settings are restored\n\
1429 even in case of abnormal exit (throw or error).\n\
1431 The value returned is the value of the last form in BODY.\n\
1433 `save-restriction' can get confused if, within the BODY, you widen\n\
1434 and then make changes outside the area within the saved restrictions.\n\
1436 Note: if you are using both `save-excursion' and `save-restriction',\n\
1437 use `save-excursion' outermost:\n\
1438 (save-excursion (save-restriction ...))")
1442 register Lisp_Object val
;
1443 int count
= specpdl_ptr
- specpdl
;
1445 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1446 val
= Fprogn (body
);
1447 return unbind_to (count
, val
);
1450 /* Buffer for the most recent text displayed by Fmessage. */
1451 static char *message_text
;
1453 /* Allocated length of that buffer. */
1454 static int message_length
;
1456 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1457 "Print a one-line message at the bottom of the screen.\n\
1458 The first argument is a control string.\n\
1459 It may contain %s or %d or %c to print successive following arguments.\n\
1460 %s means print an argument as a string, %d means print as number in decimal,\n\
1461 %c means print a number as a single character.\n\
1462 The argument used by %s must be a string or a symbol;\n\
1463 the argument used by %d or %c must be a number.\n\
1464 If the first argument is nil, clear any existing message; let the\n\
1465 minibuffer contents show.")
1477 register Lisp_Object val
;
1478 val
= Fformat (nargs
, args
);
1479 /* Copy the data so that it won't move when we GC. */
1482 message_text
= (char *)xmalloc (80);
1483 message_length
= 80;
1485 if (XSTRING (val
)->size
> message_length
)
1487 message_length
= XSTRING (val
)->size
;
1488 message_text
= (char *)xrealloc (message_text
, message_length
);
1490 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1491 message2 (message_text
, XSTRING (val
)->size
);
1496 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
1497 "Display a message, in a dialog box if possible.\n\
1498 If a dialog box is not available, use the echo area.\n\
1499 The first argument is a control string.\n\
1500 It may contain %s or %d or %c to print successive following arguments.\n\
1501 %s means print an argument as a string, %d means print as number in decimal,\n\
1502 %c means print a number as a single character.\n\
1503 The argument used by %s must be a string or a symbol;\n\
1504 the argument used by %d or %c must be a number.\n\
1505 If the first argument is nil, clear any existing message; let the\n\
1506 minibuffer contents show.")
1518 register Lisp_Object val
;
1519 val
= Fformat (nargs
, args
);
1522 Lisp_Object pane
, menu
, obj
;
1523 struct gcpro gcpro1
;
1524 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
1526 menu
= Fcons (val
, pane
);
1527 obj
= Fx_popup_dialog (Qt
, menu
);
1532 /* Copy the data so that it won't move when we GC. */
1535 message_text
= (char *)xmalloc (80);
1536 message_length
= 80;
1538 if (XSTRING (val
)->size
> message_length
)
1540 message_length
= XSTRING (val
)->size
;
1541 message_text
= (char *)xrealloc (message_text
, message_length
);
1543 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1544 message2 (message_text
, XSTRING (val
)->size
);
1550 extern Lisp_Object last_nonmenu_event
;
1552 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
1553 "Display a message in a dialog box or in the echo area.\n\
1554 If this command was invoked with the mouse, use a dialog box.\n\
1555 Otherwise, use the echo area.\n\
1557 The first argument is a control string.\n\
1558 It may contain %s or %d or %c to print successive following arguments.\n\
1559 %s means print an argument as a string, %d means print as number in decimal,\n\
1560 %c means print a number as a single character.\n\
1561 The argument used by %s must be a string or a symbol;\n\
1562 the argument used by %d or %c must be a number.\n\
1563 If the first argument is nil, clear any existing message; let the\n\
1564 minibuffer contents show.")
1570 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1571 return Fmessage_box (nargs
, args
);
1573 return Fmessage (nargs
, args
);
1576 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1577 "Format a string out of a control-string and arguments.\n\
1578 The first argument is a control string.\n\
1579 The other arguments are substituted into it to make the result, a string.\n\
1580 It may contain %-sequences meaning to substitute the next argument.\n\
1581 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1582 %d means print as number in decimal (%o octal, %x hex).\n\
1583 %c means print a number as a single character.\n\
1584 %S means print any object as an s-expression (using prin1).\n\
1585 The argument used for %d, %o, %x or %c must be a number.\n\
1586 Use %% to put a single % into the output.")
1589 register Lisp_Object
*args
;
1591 register int n
; /* The number of the next arg to substitute */
1592 register int total
= 5; /* An estimate of the final length */
1594 register unsigned char *format
, *end
;
1596 extern char *index ();
1597 /* It should not be necessary to GCPRO ARGS, because
1598 the caller in the interpreter should take care of that. */
1600 CHECK_STRING (args
[0], 0);
1601 format
= XSTRING (args
[0])->data
;
1602 end
= format
+ XSTRING (args
[0])->size
;
1605 while (format
!= end
)
1606 if (*format
++ == '%')
1610 /* Process a numeric arg and skip it. */
1611 minlen
= atoi (format
);
1616 while ((*format
>= '0' && *format
<= '9')
1617 || *format
== '-' || *format
== ' ' || *format
== '.')
1622 else if (++n
>= nargs
)
1623 error ("not enough arguments for format string");
1624 else if (*format
== 'S')
1626 /* For `S', prin1 the argument and then treat like a string. */
1627 register Lisp_Object tem
;
1628 tem
= Fprin1_to_string (args
[n
], Qnil
);
1632 else if (SYMBOLP (args
[n
]))
1634 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
1637 else if (STRINGP (args
[n
]))
1640 if (*format
!= 's' && *format
!= 'S')
1641 error ("format specifier doesn't match argument type");
1642 total
+= XSTRING (args
[n
])->size
;
1644 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1645 else if (INTEGERP (args
[n
]) && *format
!= 's')
1647 #ifdef LISP_FLOAT_TYPE
1648 /* The following loop assumes the Lisp type indicates
1649 the proper way to pass the argument.
1650 So make sure we have a flonum if the argument should
1652 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1653 args
[n
] = Ffloat (args
[n
]);
1657 #ifdef LISP_FLOAT_TYPE
1658 else if (FLOATP (args
[n
]) && *format
!= 's')
1660 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1661 args
[n
] = Ftruncate (args
[n
]);
1667 /* Anything but a string, convert to a string using princ. */
1668 register Lisp_Object tem
;
1669 tem
= Fprin1_to_string (args
[n
], Qt
);
1676 register int nstrings
= n
+ 1;
1678 /* Allocate twice as many strings as we have %-escapes; floats occupy
1679 two slots, and we're not sure how many of those we have. */
1680 register unsigned char **strings
1681 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1685 for (n
= 0; n
< nstrings
; n
++)
1688 strings
[i
++] = (unsigned char *) "";
1689 else if (INTEGERP (args
[n
]))
1690 /* We checked above that the corresponding format effector
1691 isn't %s, which would cause MPV. */
1692 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1693 #ifdef LISP_FLOAT_TYPE
1694 else if (FLOATP (args
[n
]))
1696 union { double d
; int half
[2]; } u
;
1698 u
.d
= XFLOAT (args
[n
])->data
;
1699 strings
[i
++] = (unsigned char *) u
.half
[0];
1700 strings
[i
++] = (unsigned char *) u
.half
[1];
1704 strings
[i
++] = XSTRING (args
[n
])->data
;
1707 /* Format it in bigger and bigger buf's until it all fits. */
1710 buf
= (char *) alloca (total
+ 1);
1713 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1714 if (buf
[total
- 1] == 0)
1722 return make_string (buf
, length
);
1728 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1729 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
1743 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1745 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1747 return build_string (buf
);
1750 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1751 "Return t if two characters match, optionally ignoring case.\n\
1752 Both arguments must be characters (i.e. integers).\n\
1753 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1755 register Lisp_Object c1
, c2
;
1757 unsigned char *downcase
= DOWNCASE_TABLE
;
1758 CHECK_NUMBER (c1
, 0);
1759 CHECK_NUMBER (c2
, 1);
1761 if (!NILP (current_buffer
->case_fold_search
)
1762 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1763 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1764 : XINT (c1
) == XINT (c2
))
1769 /* Transpose the markers in two regions of the current buffer, and
1770 adjust the ones between them if necessary (i.e.: if the regions
1773 Traverses the entire marker list of the buffer to do so, adding an
1774 appropriate amount to some, subtracting from some, and leaving the
1775 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1777 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1780 transpose_markers (start1
, end1
, start2
, end2
)
1781 register int start1
, end1
, start2
, end2
;
1783 register int amt1
, amt2
, diff
, mpos
;
1784 register Lisp_Object marker
;
1786 /* Update point as if it were a marker. */
1790 TEMP_SET_PT (PT
+ (end2
- end1
));
1791 else if (PT
< start2
)
1792 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1794 TEMP_SET_PT (PT
- (start2
- start1
));
1796 /* We used to adjust the endpoints here to account for the gap, but that
1797 isn't good enough. Even if we assume the caller has tried to move the
1798 gap out of our way, it might still be at start1 exactly, for example;
1799 and that places it `inside' the interval, for our purposes. The amount
1800 of adjustment is nontrivial if there's a `denormalized' marker whose
1801 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1802 the dirty work to Fmarker_position, below. */
1804 /* The difference between the region's lengths */
1805 diff
= (end2
- start2
) - (end1
- start1
);
1807 /* For shifting each marker in a region by the length of the other
1808 * region plus the distance between the regions.
1810 amt1
= (end2
- start2
) + (start2
- end1
);
1811 amt2
= (end1
- start1
) + (start2
- end1
);
1813 for (marker
= current_buffer
->markers
; !NILP (marker
);
1814 marker
= XMARKER (marker
)->chain
)
1816 mpos
= Fmarker_position (marker
);
1817 if (mpos
>= start1
&& mpos
< end2
)
1821 else if (mpos
< start2
)
1825 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1826 XMARKER (marker
)->bufpos
= mpos
;
1831 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1832 "Transpose region START1 to END1 with START2 to END2.\n\
1833 The regions may not be overlapping, because the size of the buffer is\n\
1834 never changed in a transposition.\n\
1836 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1837 any markers that happen to be located in the regions.\n\
1839 Transposing beyond buffer boundaries is an error.")
1840 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1841 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1843 register int start1
, end1
, start2
, end2
,
1844 gap
, len1
, len_mid
, len2
;
1845 unsigned char *start1_addr
, *start2_addr
, *temp
;
1847 #ifdef USE_TEXT_PROPERTIES
1848 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1849 cur_intv
= current_buffer
->intervals
;
1850 #endif /* USE_TEXT_PROPERTIES */
1852 validate_region (&startr1
, &endr1
);
1853 validate_region (&startr2
, &endr2
);
1855 start1
= XFASTINT (startr1
);
1856 end1
= XFASTINT (endr1
);
1857 start2
= XFASTINT (startr2
);
1858 end2
= XFASTINT (endr2
);
1861 /* Swap the regions if they're reversed. */
1864 register int glumph
= start1
;
1872 len1
= end1
- start1
;
1873 len2
= end2
- start2
;
1876 error ("transposed regions not properly ordered");
1877 else if (start1
== end1
|| start2
== end2
)
1878 error ("transposed region may not be of length 0");
1880 /* The possibilities are:
1881 1. Adjacent (contiguous) regions, or separate but equal regions
1882 (no, really equal, in this case!), or
1883 2. Separate regions of unequal size.
1885 The worst case is usually No. 2. It means that (aside from
1886 potential need for getting the gap out of the way), there also
1887 needs to be a shifting of the text between the two regions. So
1888 if they are spread far apart, we are that much slower... sigh. */
1890 /* It must be pointed out that the really studly thing to do would
1891 be not to move the gap at all, but to leave it in place and work
1892 around it if necessary. This would be extremely efficient,
1893 especially considering that people are likely to do
1894 transpositions near where they are working interactively, which
1895 is exactly where the gap would be found. However, such code
1896 would be much harder to write and to read. So, if you are
1897 reading this comment and are feeling squirrely, by all means have
1898 a go! I just didn't feel like doing it, so I will simply move
1899 the gap the minimum distance to get it out of the way, and then
1900 deal with an unbroken array. */
1902 /* Make sure the gap won't interfere, by moving it out of the text
1903 we will operate on. */
1904 if (start1
< gap
&& gap
< end2
)
1906 if (gap
- start1
< end2
- gap
)
1912 /* Hmmm... how about checking to see if the gap is large
1913 enough to use as the temporary storage? That would avoid an
1914 allocation... interesting. Later, don't fool with it now. */
1916 /* Working without memmove, for portability (sigh), so must be
1917 careful of overlapping subsections of the array... */
1919 if (end1
== start2
) /* adjacent regions */
1921 modify_region (current_buffer
, start1
, end2
);
1922 record_change (start1
, len1
+ len2
);
1924 #ifdef USE_TEXT_PROPERTIES
1925 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1926 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1927 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1928 #endif /* USE_TEXT_PROPERTIES */
1930 /* First region smaller than second. */
1933 /* We use alloca only if it is small,
1934 because we want to avoid stack overflow. */
1936 temp
= (unsigned char *) xmalloc (len2
);
1938 temp
= (unsigned char *) alloca (len2
);
1940 /* Don't precompute these addresses. We have to compute them
1941 at the last minute, because the relocating allocator might
1942 have moved the buffer around during the xmalloc. */
1943 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1944 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1946 bcopy (start2_addr
, temp
, len2
);
1947 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1948 bcopy (temp
, start1_addr
, len2
);
1953 /* First region not smaller than second. */
1956 temp
= (unsigned char *) xmalloc (len1
);
1958 temp
= (unsigned char *) alloca (len1
);
1959 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1960 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1961 bcopy (start1_addr
, temp
, len1
);
1962 bcopy (start2_addr
, start1_addr
, len2
);
1963 bcopy (temp
, start1_addr
+ len2
, len1
);
1967 #ifdef USE_TEXT_PROPERTIES
1968 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1969 len1
, current_buffer
, 0);
1970 graft_intervals_into_buffer (tmp_interval2
, start1
,
1971 len2
, current_buffer
, 0);
1972 #endif /* USE_TEXT_PROPERTIES */
1974 /* Non-adjacent regions, because end1 != start2, bleagh... */
1978 /* Regions are same size, though, how nice. */
1980 modify_region (current_buffer
, start1
, end1
);
1981 modify_region (current_buffer
, start2
, end2
);
1982 record_change (start1
, len1
);
1983 record_change (start2
, len2
);
1984 #ifdef USE_TEXT_PROPERTIES
1985 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1986 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1987 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
1988 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
1989 #endif /* USE_TEXT_PROPERTIES */
1992 temp
= (unsigned char *) xmalloc (len1
);
1994 temp
= (unsigned char *) alloca (len1
);
1995 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1996 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1997 bcopy (start1_addr
, temp
, len1
);
1998 bcopy (start2_addr
, start1_addr
, len2
);
1999 bcopy (temp
, start2_addr
, len1
);
2002 #ifdef USE_TEXT_PROPERTIES
2003 graft_intervals_into_buffer (tmp_interval1
, start2
,
2004 len1
, current_buffer
, 0);
2005 graft_intervals_into_buffer (tmp_interval2
, start1
,
2006 len2
, current_buffer
, 0);
2007 #endif /* USE_TEXT_PROPERTIES */
2010 else if (len1
< len2
) /* Second region larger than first */
2011 /* Non-adjacent & unequal size, area between must also be shifted. */
2013 len_mid
= start2
- end1
;
2014 modify_region (current_buffer
, start1
, end2
);
2015 record_change (start1
, (end2
- start1
));
2016 #ifdef USE_TEXT_PROPERTIES
2017 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2018 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2019 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2020 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2021 #endif /* USE_TEXT_PROPERTIES */
2023 /* holds region 2 */
2025 temp
= (unsigned char *) xmalloc (len2
);
2027 temp
= (unsigned char *) alloca (len2
);
2028 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2029 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2030 bcopy (start2_addr
, temp
, len2
);
2031 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
2032 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2033 bcopy (temp
, start1_addr
, len2
);
2036 #ifdef USE_TEXT_PROPERTIES
2037 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2038 len1
, current_buffer
, 0);
2039 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2040 len_mid
, current_buffer
, 0);
2041 graft_intervals_into_buffer (tmp_interval2
, start1
,
2042 len2
, current_buffer
, 0);
2043 #endif /* USE_TEXT_PROPERTIES */
2046 /* Second region smaller than first. */
2048 len_mid
= start2
- end1
;
2049 record_change (start1
, (end2
- start1
));
2050 modify_region (current_buffer
, start1
, end2
);
2052 #ifdef USE_TEXT_PROPERTIES
2053 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2054 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2055 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2056 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2057 #endif /* USE_TEXT_PROPERTIES */
2059 /* holds region 1 */
2061 temp
= (unsigned char *) xmalloc (len1
);
2063 temp
= (unsigned char *) alloca (len1
);
2064 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2065 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2066 bcopy (start1_addr
, temp
, len1
);
2067 bcopy (start2_addr
, start1_addr
, len2
);
2068 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2069 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
2072 #ifdef USE_TEXT_PROPERTIES
2073 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2074 len1
, current_buffer
, 0);
2075 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2076 len_mid
, current_buffer
, 0);
2077 graft_intervals_into_buffer (tmp_interval2
, start1
,
2078 len2
, current_buffer
, 0);
2079 #endif /* USE_TEXT_PROPERTIES */
2083 /* todo: this will be slow, because for every transposition, we
2084 traverse the whole friggin marker list. Possible solutions:
2085 somehow get a list of *all* the markers across multiple
2086 transpositions and do it all in one swell phoop. Or maybe modify
2087 Emacs' marker code to keep an ordered list or tree. This might
2088 be nicer, and more beneficial in the long run, but would be a
2089 bunch of work. Plus the way they're arranged now is nice. */
2090 if (NILP (leave_markers
))
2092 transpose_markers (start1
, end1
, start2
, end2
);
2093 fix_overlays_in_range (start1
, end2
);
2103 DEFVAR_LISP ("system-name", &Vsystem_name
,
2104 "The name of the machine Emacs is running on.");
2106 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2107 "The full name of the user logged in.");
2109 DEFVAR_LISP ("user-name", &Vuser_name
,
2110 "The user's name, taken from environment variables if possible.");
2112 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
2113 "The user's name, based upon the real uid only.");
2115 defsubr (&Schar_equal
);
2116 defsubr (&Sgoto_char
);
2117 defsubr (&Sstring_to_char
);
2118 defsubr (&Schar_to_string
);
2119 defsubr (&Sbuffer_substring
);
2120 defsubr (&Sbuffer_string
);
2122 defsubr (&Spoint_marker
);
2123 defsubr (&Smark_marker
);
2125 defsubr (&Sregion_beginning
);
2126 defsubr (&Sregion_end
);
2127 /* defsubr (&Smark); */
2128 /* defsubr (&Sset_mark); */
2129 defsubr (&Ssave_excursion
);
2131 defsubr (&Sbufsize
);
2132 defsubr (&Spoint_max
);
2133 defsubr (&Spoint_min
);
2134 defsubr (&Spoint_min_marker
);
2135 defsubr (&Spoint_max_marker
);
2141 defsubr (&Sfollowing_char
);
2142 defsubr (&Sprevious_char
);
2143 defsubr (&Schar_after
);
2145 defsubr (&Sinsert_before_markers
);
2146 defsubr (&Sinsert_and_inherit
);
2147 defsubr (&Sinsert_and_inherit_before_markers
);
2148 defsubr (&Sinsert_char
);
2150 defsubr (&Suser_login_name
);
2151 defsubr (&Suser_real_login_name
);
2152 defsubr (&Suser_uid
);
2153 defsubr (&Suser_real_uid
);
2154 defsubr (&Suser_full_name
);
2155 defsubr (&Semacs_pid
);
2156 defsubr (&Scurrent_time
);
2157 defsubr (&Sformat_time_string
);
2158 defsubr (&Scurrent_time_string
);
2159 defsubr (&Scurrent_time_zone
);
2160 defsubr (&Ssystem_name
);
2161 defsubr (&Smessage
);
2162 defsubr (&Smessage_box
);
2163 defsubr (&Smessage_or_box
);
2166 defsubr (&Sinsert_buffer_substring
);
2167 defsubr (&Scompare_buffer_substrings
);
2168 defsubr (&Ssubst_char_in_region
);
2169 defsubr (&Stranslate_region
);
2170 defsubr (&Sdelete_region
);
2172 defsubr (&Snarrow_to_region
);
2173 defsubr (&Ssave_restriction
);
2174 defsubr (&Stranspose_regions
);