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 extern void insert_from_buffer ();
43 /* Some static data, and a function to initialize it for each run */
45 Lisp_Object Vsystem_name
;
46 Lisp_Object Vuser_real_name
; /* login name of current user ID */
47 Lisp_Object Vuser_full_name
; /* full name of current user */
48 Lisp_Object Vuser_name
; /* user name from LOGNAME or USER */
54 register unsigned char *p
, *q
, *r
;
55 struct passwd
*pw
; /* password entry for the current user */
56 extern char *index ();
59 /* Set up system_name even when dumping. */
63 /* Don't bother with this on initial start when just dumping out */
66 #endif /* not CANNOT_DUMP */
68 pw
= (struct passwd
*) getpwuid (getuid ());
70 /* We let the real user name default to "root" because that's quite
71 accurate on MSDOG and because it lets Emacs find the init file.
72 (The DVX libraries override the Djgpp libraries here.) */
73 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "root");
75 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
78 /* Get the effective user name, by consulting environment variables,
79 or the effective uid if those are unset. */
80 user_name
= (char *) getenv ("LOGNAME");
82 user_name
= (char *) getenv ("USER");
85 pw
= (struct passwd
*) getpwuid (geteuid ());
86 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
88 Vuser_name
= build_string (user_name
);
90 /* If the user name claimed in the environment vars differs from
91 the real uid, use the claimed name to find the full name. */
92 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
94 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
96 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
97 q
= (unsigned char *) index (p
, ',');
98 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
100 #ifdef AMPERSAND_FULL_NAME
101 p
= XSTRING (Vuser_full_name
)->data
;
102 q
= (char *) index (p
, '&');
103 /* Substitute the login name for the &, upcasing the first character. */
106 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
109 strcat (r
, XSTRING (Vuser_name
)->data
);
110 r
[q
- p
] = UPCASE (r
[q
- p
]);
112 Vuser_full_name
= build_string (r
);
114 #endif /* AMPERSAND_FULL_NAME */
117 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
118 "Convert arg CHAR to a one-character string containing that character.")
126 return make_string (&c
, 1);
129 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
130 "Convert arg STRING to a character, the first character of that string.")
132 register Lisp_Object str
;
134 register Lisp_Object val
;
135 register struct Lisp_String
*p
;
136 CHECK_STRING (str
, 0);
140 XSETFASTINT (val
, ((unsigned char *) p
->data
)[0]);
142 XSETFASTINT (val
, 0);
150 register Lisp_Object mark
;
151 mark
= Fmake_marker ();
152 Fset_marker (mark
, make_number (val
), Qnil
);
156 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
157 "Return value of point, as an integer.\n\
158 Beginning of buffer is position (point-min)")
162 XSETFASTINT (temp
, point
);
166 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
167 "Return value of point, as a marker object.")
170 return buildmark (point
);
174 clip_to_bounds (lower
, num
, upper
)
175 int lower
, num
, upper
;
179 else if (num
> upper
)
185 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
186 "Set point to POSITION, a number or marker.\n\
187 Beginning of buffer is position (point-min), end is (point-max).")
189 register Lisp_Object n
;
191 CHECK_NUMBER_COERCE_MARKER (n
, 0);
193 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
198 region_limit (beginningp
)
201 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
202 register Lisp_Object m
;
203 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
204 && NILP (current_buffer
->mark_active
))
205 Fsignal (Qmark_inactive
, Qnil
);
206 m
= Fmarker_position (current_buffer
->mark
);
207 if (NILP (m
)) error ("There is no region now");
208 if ((point
< XFASTINT (m
)) == beginningp
)
209 return (make_number (point
));
214 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
215 "Return position of beginning of region, as an integer.")
218 return (region_limit (1));
221 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
222 "Return position of end of region, as an integer.")
225 return (region_limit (0));
228 #if 0 /* now in lisp code */
229 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
230 "Return this buffer's mark value as integer, or nil if no mark.\n\
231 If you are using this in an editing command, you are most likely making\n\
232 a mistake; see the documentation of `set-mark'.")
235 return Fmarker_position (current_buffer
->mark
);
237 #endif /* commented out code */
239 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
240 "Return this buffer's mark, as a marker object.\n\
241 Watch out! Moving this marker changes the mark position.\n\
242 If you set the marker not to point anywhere, the buffer will have no mark.")
245 return current_buffer
->mark
;
248 #if 0 /* this is now in lisp code */
249 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
250 "Set this buffer's mark to POS. Don't use this function!\n\
251 That is to say, don't use this function unless you want\n\
252 the user to see that the mark has moved, and you want the previous\n\
253 mark position to be lost.\n\
255 Normally, when a new mark is set, the old one should go on the stack.\n\
256 This is why most applications should use push-mark, not set-mark.\n\
258 Novice programmers often try to use the mark for the wrong purposes.\n\
259 The mark saves a location for the user's convenience.\n\
260 Most editing commands should not alter the mark.\n\
261 To remember a location for internal use in the Lisp program,\n\
262 store it in a Lisp variable. Example:\n\
264 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
270 current_buffer
->mark
= Qnil
;
273 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
275 if (NILP (current_buffer
->mark
))
276 current_buffer
->mark
= Fmake_marker ();
278 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
281 #endif /* commented-out code */
284 save_excursion_save ()
286 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
289 return Fcons (Fpoint_marker (),
290 Fcons (Fcopy_marker (current_buffer
->mark
),
291 Fcons (visible
? Qt
: Qnil
,
292 current_buffer
->mark_active
)));
296 save_excursion_restore (info
)
297 register Lisp_Object info
;
299 register Lisp_Object tem
, tem1
, omark
, nmark
;
301 tem
= Fmarker_buffer (Fcar (info
));
302 /* If buffer being returned to is now deleted, avoid error */
303 /* Otherwise could get error here while unwinding to top level
305 /* In that case, Fmarker_buffer returns nil now. */
311 unchain_marker (tem
);
312 tem
= Fcar (Fcdr (info
));
313 omark
= Fmarker_position (current_buffer
->mark
);
314 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
315 nmark
= Fmarker_position (tem
);
316 unchain_marker (tem
);
317 tem
= Fcdr (Fcdr (info
));
318 #if 0 /* We used to make the current buffer visible in the selected window
319 if that was true previously. That avoids some anomalies.
320 But it creates others, and it wasn't documented, and it is simpler
321 and cleaner never to alter the window/buffer connections. */
324 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
325 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
328 tem1
= current_buffer
->mark_active
;
329 current_buffer
->mark_active
= Fcdr (tem
);
330 if (!NILP (Vrun_hooks
))
332 /* If mark is active now, and either was not active
333 or was at a different place, run the activate hook. */
334 if (! NILP (current_buffer
->mark_active
))
336 if (! EQ (omark
, nmark
))
337 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
339 /* If mark has ceased to be active, run deactivate hook. */
340 else if (! NILP (tem1
))
341 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
346 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
347 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
348 Executes BODY just like `progn'.\n\
349 The values of point, mark and the current buffer are restored\n\
350 even in case of abnormal exit (throw or error).\n\
351 The state of activation of the mark is also restored.")
355 register Lisp_Object val
;
356 int count
= specpdl_ptr
- specpdl
;
358 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
361 return unbind_to (count
, val
);
364 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
365 "Return the number of characters in the current buffer.")
369 XSETFASTINT (temp
, Z
- BEG
);
373 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
374 "Return the minimum permissible value of point in the current buffer.\n\
375 This is 1, unless narrowing (a buffer restriction) is in effect.")
379 XSETFASTINT (temp
, BEGV
);
383 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
384 "Return a marker to the minimum permissible value of point in this buffer.\n\
385 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
388 return buildmark (BEGV
);
391 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
392 "Return the maximum permissible value of point in the current buffer.\n\
393 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
394 is in effect, in which case it is less.")
398 XSETFASTINT (temp
, ZV
);
402 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
403 "Return a marker to the maximum permissible value of point in this buffer.\n\
404 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
405 is in effect, in which case it is less.")
408 return buildmark (ZV
);
411 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
412 "Return the character following point, as a number.\n\
413 At the end of the buffer or accessible region, return 0.")
418 XSETFASTINT (temp
, 0);
420 XSETFASTINT (temp
, FETCH_CHAR (point
));
424 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
425 "Return the character preceding point, as a number.\n\
426 At the beginning of the buffer or accessible region, return 0.")
431 XSETFASTINT (temp
, 0);
433 XSETFASTINT (temp
, FETCH_CHAR (point
- 1));
437 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
438 "Return T if point is at the beginning of the buffer.\n\
439 If the buffer is narrowed, this means the beginning of the narrowed part.")
447 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
448 "Return T if point is at the end of the buffer.\n\
449 If the buffer is narrowed, this means the end of the narrowed part.")
457 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
458 "Return T if point is at the beginning of a line.")
461 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
466 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
467 "Return T if point is at the end of a line.\n\
468 `End of a line' includes point being at the end of the buffer.")
471 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
476 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
477 "Return character in current buffer at position POS.\n\
478 POS is an integer or a buffer pointer.\n\
479 If POS is out of range, the value is nil.")
483 register Lisp_Object val
;
486 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
489 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
491 XSETFASTINT (val
, FETCH_CHAR (n
));
495 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
496 "Return the name under which the user logged in, as a string.\n\
497 This is based on the effective uid, not the real uid.\n\
498 Also, if the environment variable LOGNAME or USER is set,\n\
499 that determines the value of this function.\n\n\
500 If optional argument UID is an integer, return the login name of the user\n\
501 with that uid, or nil if there is no such user.")
507 /* Set up the user name info if we didn't do it before.
508 (That can happen if Emacs is dumpable
509 but you decide to run `temacs -l loadup' and not dump. */
510 if (INTEGERP (Vuser_name
))
516 CHECK_NUMBER (uid
, 0);
517 pw
= (struct passwd
*) getpwuid (XINT (uid
));
518 return (pw
? build_string (pw
->pw_name
) : Qnil
);
521 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
523 "Return the name of the user's real uid, as a string.\n\
524 This ignores the environment variables LOGNAME and USER, so it differs from\n\
525 `user-login-name' when running under `su'.")
528 /* Set up the user name info if we didn't do it before.
529 (That can happen if Emacs is dumpable
530 but you decide to run `temacs -l loadup' and not dump. */
531 if (INTEGERP (Vuser_name
))
533 return Vuser_real_name
;
536 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
537 "Return the effective uid of Emacs, as an integer.")
540 return make_number (geteuid ());
543 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
544 "Return the real uid of Emacs, as an integer.")
547 return make_number (getuid ());
550 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
551 "Return the full name of the user logged in, as a string.")
554 return Vuser_full_name
;
557 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
558 "Return the name of the machine you are running on, as a string.")
564 /* For the benefit of callers who don't want to include lisp.h */
568 return (char *) XSTRING (Vsystem_name
)->data
;
571 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
572 "Return the process ID of Emacs, as an integer.")
575 return make_number (getpid ());
578 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
579 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
580 The time is returned as a list of three integers. The first has the\n\
581 most significant 16 bits of the seconds, while the second has the\n\
582 least significant 16 bits. The third integer gives the microsecond\n\
585 The microsecond count is zero on systems that do not provide\n\
586 resolution finer than a second.")
590 Lisp_Object result
[3];
593 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
594 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
595 XSETINT (result
[2], EMACS_USECS (t
));
597 return Flist (3, result
);
602 lisp_time_argument (specified_time
, result
)
603 Lisp_Object specified_time
;
606 if (NILP (specified_time
))
607 return time (result
) != -1;
610 Lisp_Object high
, low
;
611 high
= Fcar (specified_time
);
612 CHECK_NUMBER (high
, 0);
613 low
= Fcdr (specified_time
);
616 CHECK_NUMBER (low
, 0);
617 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
618 return *result
>> 16 == XINT (high
);
622 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 2, 2, 0,
623 "Use FORMAT-STRING to format the time TIME.\n\
624 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from\n\
625 `current-time' and `file-attributes'.\n\
626 FORMAT-STRING may contain %-sequences to substitute parts of the time.\n\
627 %a is replaced by the abbreviated name of the day of week.\n\
628 %A is replaced by the full name of the day of week.\n\
629 %b is replaced by the abbreviated name of the month.\n\
630 %B is replaced by the full name of the month.\n\
631 %c is a synonym for \"%x %X\".\n\
632 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.\n\
633 %d is replaced by the day of month, zero-padded.\n\
634 %D is a synonym for \"%m/%d/%y\".\n\
635 %e is replaced by the day of month, blank-padded.\n\
636 %h is a synonym for \"%b\".\n\
637 %H is replaced by the hour (00-23).\n\
638 %I is replaced by the hour (00-12).\n\
639 %j is replaced by the day of the year (001-366).\n\
640 %k is replaced by the hour (0-23), blank padded.\n\
641 %l is replaced by the hour (1-12), blank padded.\n\
642 %m is replaced by the month (01-12).\n\
643 %M is replaced by the minut (00-59).\n\
644 %n is a synonym for \"\\n\".\n\
645 %p is replaced by AM or PM, as appropriate.\n\
646 %r is a synonym for \"%I:%M:%S %p\".\n\
647 %R is a synonym for \"%H:%M\".\n\
648 %S is replaced by the seconds (00-60).\n\
649 %t is a synonym for \"\\t\".\n\
650 %T is a synonym for \"%H:%M:%S\".\n\
651 %U is replaced by the week of the year (01-52), first day of week is Sunday.\n\
652 %w is replaced by the day of week (0-6), Sunday is day 0.\n\
653 %W is replaced by the week of the year (01-52), first day of week is Monday.\n\
654 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.\n\
655 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.\n\
656 %y is replaced by the year without century (00-99).\n\
657 %Y is replaced by the year with century.\n\
658 %Z is replaced by the time zone abbreviation.\n\
660 The number of options reflects the strftime(3) function.")
661 (format_string
, time
)
662 Lisp_Object format_string
, time
;
667 CHECK_STRING (format_string
, 1);
669 if (! lisp_time_argument (time
, &value
))
670 error ("Invalid time specification");
672 /* This is probably enough. */
673 size
= XSTRING (format_string
)->size
* 6 + 50;
677 char *buf
= (char *) alloca (size
);
678 if (strftime (buf
, size
, XSTRING (format_string
)->data
,
680 return build_string (buf
);
681 /* If buffer was too small, make it bigger. */
686 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
687 "Return the current time, as a human-readable string.\n\
688 Programs can use this function to decode a time,\n\
689 since the number of columns in each field is fixed.\n\
690 The format is `Sun Sep 16 01:03:52 1973'.\n\
691 If an argument is given, it specifies a time to format\n\
692 instead of the current time. The argument should have the form:\n\
695 (HIGH LOW . IGNORED).\n\
696 Thus, you can use times obtained from `current-time'\n\
697 and from `file-attributes'.")
699 Lisp_Object specified_time
;
705 if (! lisp_time_argument (specified_time
, &value
))
707 tem
= (char *) ctime (&value
);
709 strncpy (buf
, tem
, 24);
712 return build_string (buf
);
715 #define TM_YEAR_ORIGIN 1900
717 /* Yield A - B, measured in seconds. */
722 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
723 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
724 /* Some compilers can't handle this as a single return statement. */
726 /* difference in day of year */
727 a
->tm_yday
- b
->tm_yday
728 /* + intervening leap days */
729 + ((ay
>> 2) - (by
>> 2))
731 + ((ay
/100 >> 2) - (by
/100 >> 2))
732 /* + difference in years * 365 */
733 + (long)(ay
-by
) * 365
735 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
736 + (a
->tm_min
- b
->tm_min
))
737 + (a
->tm_sec
- b
->tm_sec
));
740 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
741 "Return the offset and name for the local time zone.\n\
742 This returns a list of the form (OFFSET NAME).\n\
743 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
744 A negative value means west of Greenwich.\n\
745 NAME is a string giving the name of the time zone.\n\
746 If an argument is given, it specifies when the time zone offset is determined\n\
747 instead of using the current time. The argument should have the form:\n\
750 (HIGH LOW . IGNORED).\n\
751 Thus, you can use times obtained from `current-time'\n\
752 and from `file-attributes'.\n\
754 Some operating systems cannot provide all this information to Emacs;\n\
755 in this case, `current-time-zone' returns a list containing nil for\n\
756 the data it can't find.")
758 Lisp_Object specified_time
;
763 if (lisp_time_argument (specified_time
, &value
)
764 && (t
= gmtime (&value
)) != 0)
770 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
771 t
= localtime (&value
);
772 offset
= difftm (t
, &gmt
);
776 s
= (char *)t
->tm_zone
;
777 #else /* not HAVE_TM_ZONE */
779 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
780 s
= tzname
[t
->tm_isdst
];
782 #endif /* not HAVE_TM_ZONE */
785 /* No local time zone name is available; use "+-NNNN" instead. */
786 int am
= (offset
< 0 ? -offset
: offset
) / 60;
787 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
790 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
793 return Fmake_list (2, Qnil
);
805 /* Callers passing one argument to Finsert need not gcpro the
806 argument "array", since the only element of the array will
807 not be used after calling insert or insert_from_string, so
808 we don't care if it gets trashed. */
810 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
811 "Insert the arguments, either strings or characters, at point.\n\
812 Point moves forward so that it ends up after the inserted text.\n\
813 Any other markers at the point of insertion remain before the text.")
816 register Lisp_Object
*args
;
819 register Lisp_Object tem
;
822 for (argnum
= 0; argnum
< nargs
; argnum
++)
831 else if (STRINGP (tem
))
833 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
837 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
845 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
847 "Insert the arguments at point, inheriting properties from adjoining text.\n\
848 Point moves forward so that it ends up after the inserted text.\n\
849 Any other markers at the point of insertion remain before the text.")
852 register Lisp_Object
*args
;
855 register Lisp_Object tem
;
858 for (argnum
= 0; argnum
< nargs
; argnum
++)
865 insert_and_inherit (str
, 1);
867 else if (STRINGP (tem
))
869 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
873 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
881 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
882 "Insert strings or characters at point, relocating markers after the text.\n\
883 Point moves forward so that it ends up after the inserted text.\n\
884 Any other markers at the point of insertion also end up after the text.")
887 register Lisp_Object
*args
;
890 register Lisp_Object tem
;
893 for (argnum
= 0; argnum
< nargs
; argnum
++)
900 insert_before_markers (str
, 1);
902 else if (STRINGP (tem
))
904 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
908 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
916 DEFUN ("insert-before-markers-and-inherit",
917 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
919 "Insert text at point, relocating markers and inheriting properties.\n\
920 Point moves forward so that it ends up after the inserted text.\n\
921 Any other markers at the point of insertion also end up after the text.")
924 register Lisp_Object
*args
;
927 register Lisp_Object tem
;
930 for (argnum
= 0; argnum
< nargs
; argnum
++)
937 insert_before_markers_and_inherit (str
, 1);
939 else if (STRINGP (tem
))
941 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
945 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
953 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
954 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
955 Point and all markers are affected as in the function `insert'.\n\
956 Both arguments are required.\n\
957 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
958 from adjoining text, if those properties are sticky.")
959 (chr
, count
, inherit
)
960 Lisp_Object chr
, count
, inherit
;
962 register unsigned char *string
;
966 CHECK_NUMBER (chr
, 0);
967 CHECK_NUMBER (count
, 1);
972 strlen
= min (n
, 256);
973 string
= (unsigned char *) alloca (strlen
);
974 for (i
= 0; i
< strlen
; i
++)
975 string
[i
] = XFASTINT (chr
);
979 insert_and_inherit (string
, strlen
);
981 insert (string
, strlen
);
990 /* Making strings from buffer contents. */
992 /* Return a Lisp_String containing the text of the current buffer from
993 START to END. If text properties are in use and the current buffer
994 has properties in the range specified, the resulting string will also
997 We don't want to use plain old make_string here, because it calls
998 make_uninit_string, which can cause the buffer arena to be
999 compacted. make_string has no way of knowing that the data has
1000 been moved, and thus copies the wrong data into the string. This
1001 doesn't effect most of the other users of make_string, so it should
1002 be left as is. But we should use this function when conjuring
1003 buffer substrings. */
1006 make_buffer_string (start
, end
)
1009 Lisp_Object result
, tem
, tem1
;
1011 if (start
< GPT
&& GPT
< end
)
1014 result
= make_uninit_string (end
- start
);
1015 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
1017 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1018 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1020 #ifdef USE_TEXT_PROPERTIES
1021 if (XINT (tem
) != end
|| !NILP (tem1
))
1022 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
1028 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1029 "Return the contents of part of the current buffer as a string.\n\
1030 The two arguments START and END are character positions;\n\
1031 they can be in either order.")
1035 register int beg
, end
;
1037 validate_region (&b
, &e
);
1041 return make_buffer_string (beg
, end
);
1044 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1045 "Return the contents of the current buffer as a string.")
1048 return make_buffer_string (BEGV
, ZV
);
1051 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1053 "Insert before point a substring of the contents of buffer BUFFER.\n\
1054 BUFFER may be a buffer or a buffer name.\n\
1055 Arguments START and END are character numbers specifying the substring.\n\
1056 They default to the beginning and the end of BUFFER.")
1058 Lisp_Object buf
, b
, e
;
1060 register int beg
, end
, temp
;
1061 register struct buffer
*bp
;
1064 buffer
= Fget_buffer (buf
);
1067 bp
= XBUFFER (buffer
);
1070 beg
= BUF_BEGV (bp
);
1073 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1080 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1085 temp
= beg
, beg
= end
, end
= temp
;
1087 if (!(BUF_BEGV (bp
) <= beg
&& end
<= BUF_ZV (bp
)))
1088 args_out_of_range (b
, e
);
1090 insert_from_buffer (bp
, beg
, end
- beg
, 0);
1094 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1096 "Compare two substrings of two buffers; return result as number.\n\
1097 the value is -N if first string is less after N-1 chars,\n\
1098 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1099 Each substring is represented as three arguments: BUFFER, START and END.\n\
1100 That makes six args in all, three for each substring.\n\n\
1101 The value of `case-fold-search' in the current buffer\n\
1102 determines whether case is significant or ignored.")
1103 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1104 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1106 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1107 register struct buffer
*bp1
, *bp2
;
1108 register unsigned char *trt
1109 = (!NILP (current_buffer
->case_fold_search
)
1110 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1112 /* Find the first buffer and its substring. */
1115 bp1
= current_buffer
;
1119 buf1
= Fget_buffer (buffer1
);
1122 bp1
= XBUFFER (buf1
);
1126 begp1
= BUF_BEGV (bp1
);
1129 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1130 begp1
= XINT (start1
);
1133 endp1
= BUF_ZV (bp1
);
1136 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1137 endp1
= XINT (end1
);
1141 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1143 if (!(BUF_BEGV (bp1
) <= begp1
1145 && endp1
<= BUF_ZV (bp1
)))
1146 args_out_of_range (start1
, end1
);
1148 /* Likewise for second substring. */
1151 bp2
= current_buffer
;
1155 buf2
= Fget_buffer (buffer2
);
1158 bp2
= XBUFFER (buffer2
);
1162 begp2
= BUF_BEGV (bp2
);
1165 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1166 begp2
= XINT (start2
);
1169 endp2
= BUF_ZV (bp2
);
1172 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1173 endp2
= XINT (end2
);
1177 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1179 if (!(BUF_BEGV (bp2
) <= begp2
1181 && endp2
<= BUF_ZV (bp2
)))
1182 args_out_of_range (start2
, end2
);
1184 len1
= endp1
- begp1
;
1185 len2
= endp2
- begp2
;
1190 for (i
= 0; i
< length
; i
++)
1192 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1193 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1200 return make_number (- 1 - i
);
1202 return make_number (i
+ 1);
1205 /* The strings match as far as they go.
1206 If one is shorter, that one is less. */
1208 return make_number (length
+ 1);
1209 else if (length
< len2
)
1210 return make_number (- length
- 1);
1212 /* Same length too => they are equal. */
1213 return make_number (0);
1216 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1217 Ssubst_char_in_region
, 4, 5, 0,
1218 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1219 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1220 and don't mark the buffer as really changed.")
1221 (start
, end
, fromchar
, tochar
, noundo
)
1222 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1224 register int pos
, stop
, look
;
1227 validate_region (&start
, &end
);
1228 CHECK_NUMBER (fromchar
, 2);
1229 CHECK_NUMBER (tochar
, 3);
1233 look
= XINT (fromchar
);
1237 if (FETCH_CHAR (pos
) == look
)
1241 modify_region (current_buffer
, XINT (start
), stop
);
1243 if (! NILP (noundo
))
1245 if (MODIFF
- 1 == current_buffer
->save_modified
)
1246 current_buffer
->save_modified
++;
1247 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1248 current_buffer
->auto_save_modified
++;
1255 record_change (pos
, 1);
1256 FETCH_CHAR (pos
) = XINT (tochar
);
1262 signal_after_change (XINT (start
),
1263 stop
- XINT (start
), stop
- XINT (start
));
1268 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1269 "From START to END, translate characters according to TABLE.\n\
1270 TABLE is a string; the Nth character in it is the mapping\n\
1271 for the character with code N. Returns the number of characters changed.")
1275 register Lisp_Object table
;
1277 register int pos
, stop
; /* Limits of the region. */
1278 register unsigned char *tt
; /* Trans table. */
1279 register int oc
; /* Old character. */
1280 register int nc
; /* New character. */
1281 int cnt
; /* Number of changes made. */
1282 Lisp_Object z
; /* Return. */
1283 int size
; /* Size of translate table. */
1285 validate_region (&start
, &end
);
1286 CHECK_STRING (table
, 2);
1288 size
= XSTRING (table
)->size
;
1289 tt
= XSTRING (table
)->data
;
1293 modify_region (current_buffer
, pos
, stop
);
1296 for (; pos
< stop
; ++pos
)
1298 oc
= FETCH_CHAR (pos
);
1304 record_change (pos
, 1);
1305 FETCH_CHAR (pos
) = nc
;
1306 signal_after_change (pos
, 1, 1);
1312 XSETFASTINT (z
, cnt
);
1316 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1317 "Delete the text between point and mark.\n\
1318 When called from a program, expects two arguments,\n\
1319 positions (integers or markers) specifying the stretch to be deleted.")
1323 validate_region (&b
, &e
);
1324 del_range (XINT (b
), XINT (e
));
1328 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1329 "Remove restrictions (narrowing) from current buffer.\n\
1330 This allows the buffer's full text to be seen and edited.")
1334 SET_BUF_ZV (current_buffer
, Z
);
1336 /* Changing the buffer bounds invalidates any recorded current column. */
1337 invalidate_current_column ();
1341 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1342 "Restrict editing in this buffer to the current region.\n\
1343 The rest of the text becomes temporarily invisible and untouchable\n\
1344 but is not deleted; if you save the buffer in a file, the invisible\n\
1345 text is included in the file. \\[widen] makes all visible again.\n\
1346 See also `save-restriction'.\n\
1348 When calling from a program, pass two arguments; positions (integers\n\
1349 or markers) bounding the text that should remain visible.")
1351 register Lisp_Object b
, e
;
1353 register EMACS_INT i
;
1355 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1356 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1358 if (XINT (b
) > XINT (e
))
1365 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1366 args_out_of_range (b
, e
);
1368 BEGV
= XFASTINT (b
);
1369 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1370 if (point
< XFASTINT (b
))
1371 SET_PT (XFASTINT (b
));
1372 if (point
> XFASTINT (e
))
1373 SET_PT (XFASTINT (e
));
1375 /* Changing the buffer bounds invalidates any recorded current column. */
1376 invalidate_current_column ();
1381 save_restriction_save ()
1383 register Lisp_Object bottom
, top
;
1384 /* Note: I tried using markers here, but it does not win
1385 because insertion at the end of the saved region
1386 does not advance mh and is considered "outside" the saved region. */
1387 XSETFASTINT (bottom
, BEGV
- BEG
);
1388 XSETFASTINT (top
, Z
- ZV
);
1390 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1394 save_restriction_restore (data
)
1397 register struct buffer
*buf
;
1398 register int newhead
, newtail
;
1399 register Lisp_Object tem
;
1401 buf
= XBUFFER (XCONS (data
)->car
);
1403 data
= XCONS (data
)->cdr
;
1405 tem
= XCONS (data
)->car
;
1406 newhead
= XINT (tem
);
1407 tem
= XCONS (data
)->cdr
;
1408 newtail
= XINT (tem
);
1409 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1414 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1415 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1418 /* If point is outside the new visible range, move it inside. */
1420 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1425 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1426 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1427 The buffer's restrictions make parts of the beginning and end invisible.\n\
1428 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1429 This special form, `save-restriction', saves the current buffer's restrictions\n\
1430 when it is entered, and restores them when it is exited.\n\
1431 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1432 The old restrictions settings are restored\n\
1433 even in case of abnormal exit (throw or error).\n\
1435 The value returned is the value of the last form in BODY.\n\
1437 `save-restriction' can get confused if, within the BODY, you widen\n\
1438 and then make changes outside the area within the saved restrictions.\n\
1440 Note: if you are using both `save-excursion' and `save-restriction',\n\
1441 use `save-excursion' outermost:\n\
1442 (save-excursion (save-restriction ...))")
1446 register Lisp_Object val
;
1447 int count
= specpdl_ptr
- specpdl
;
1449 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1450 val
= Fprogn (body
);
1451 return unbind_to (count
, val
);
1454 /* Buffer for the most recent text displayed by Fmessage. */
1455 static char *message_text
;
1457 /* Allocated length of that buffer. */
1458 static int message_length
;
1460 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1461 "Print a one-line message at the bottom of the screen.\n\
1462 The first argument is a control string.\n\
1463 It may contain %s or %d or %c to print successive following arguments.\n\
1464 %s means print an argument as a string, %d means print as number in decimal,\n\
1465 %c means print a number as a single character.\n\
1466 The argument used by %s must be a string or a symbol;\n\
1467 the argument used by %d or %c must be a number.\n\
1468 If the first argument is nil, clear any existing message; let the\n\
1469 minibuffer contents show.")
1481 register Lisp_Object val
;
1482 val
= Fformat (nargs
, args
);
1483 /* Copy the data so that it won't move when we GC. */
1486 message_text
= (char *)xmalloc (80);
1487 message_length
= 80;
1489 if (XSTRING (val
)->size
> message_length
)
1491 message_length
= XSTRING (val
)->size
;
1492 message_text
= (char *)xrealloc (message_text
, message_length
);
1494 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1495 message2 (message_text
, XSTRING (val
)->size
);
1500 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
1501 "Display a message, in a dialog box if possible.\n\
1502 If a dialog box is not available, use the echo area.\n\
1503 The first argument is a control string.\n\
1504 It may contain %s or %d or %c to print successive following arguments.\n\
1505 %s means print an argument as a string, %d means print as number in decimal,\n\
1506 %c means print a number as a single character.\n\
1507 The argument used by %s must be a string or a symbol;\n\
1508 the argument used by %d or %c must be a number.\n\
1509 If the first argument is nil, clear any existing message; let the\n\
1510 minibuffer contents show.")
1522 register Lisp_Object val
;
1523 val
= Fformat (nargs
, args
);
1526 Lisp_Object pane
, menu
, obj
;
1527 struct gcpro gcpro1
;
1528 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
1530 menu
= Fcons (val
, pane
);
1531 obj
= Fx_popup_dialog (Qt
, menu
);
1536 /* Copy the data so that it won't move when we GC. */
1539 message_text
= (char *)xmalloc (80);
1540 message_length
= 80;
1542 if (XSTRING (val
)->size
> message_length
)
1544 message_length
= XSTRING (val
)->size
;
1545 message_text
= (char *)xrealloc (message_text
, message_length
);
1547 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1548 message2 (message_text
, XSTRING (val
)->size
);
1554 extern Lisp_Object last_nonmenu_event
;
1556 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
1557 "Display a message in a dialog box or in the echo area.\n\
1558 If this command was invoked with the mouse, use a dialog box.\n\
1559 Otherwise, use the echo area.\n\
1561 The first argument is a control string.\n\
1562 It may contain %s or %d or %c to print successive following arguments.\n\
1563 %s means print an argument as a string, %d means print as number in decimal,\n\
1564 %c means print a number as a single character.\n\
1565 The argument used by %s must be a string or a symbol;\n\
1566 the argument used by %d or %c must be a number.\n\
1567 If the first argument is nil, clear any existing message; let the\n\
1568 minibuffer contents show.")
1574 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1575 return Fmessage_box (nargs
, args
);
1577 return Fmessage (nargs
, args
);
1580 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1581 "Format a string out of a control-string and arguments.\n\
1582 The first argument is a control string.\n\
1583 The other arguments are substituted into it to make the result, a string.\n\
1584 It may contain %-sequences meaning to substitute the next argument.\n\
1585 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1586 %d means print as number in decimal (%o octal, %x hex).\n\
1587 %c means print a number as a single character.\n\
1588 %S means print any object as an s-expression (using prin1).\n\
1589 The argument used for %d, %o, %x or %c must be a number.\n\
1590 Use %% to put a single % into the output.")
1593 register Lisp_Object
*args
;
1595 register int n
; /* The number of the next arg to substitute */
1596 register int total
= 5; /* An estimate of the final length */
1598 register unsigned char *format
, *end
;
1600 extern char *index ();
1601 /* It should not be necessary to GCPRO ARGS, because
1602 the caller in the interpreter should take care of that. */
1604 CHECK_STRING (args
[0], 0);
1605 format
= XSTRING (args
[0])->data
;
1606 end
= format
+ XSTRING (args
[0])->size
;
1609 while (format
!= end
)
1610 if (*format
++ == '%')
1614 /* Process a numeric arg and skip it. */
1615 minlen
= atoi (format
);
1620 while ((*format
>= '0' && *format
<= '9')
1621 || *format
== '-' || *format
== ' ' || *format
== '.')
1626 else if (++n
>= nargs
)
1627 error ("not enough arguments for format string");
1628 else if (*format
== 'S')
1630 /* For `S', prin1 the argument and then treat like a string. */
1631 register Lisp_Object tem
;
1632 tem
= Fprin1_to_string (args
[n
], Qnil
);
1636 else if (SYMBOLP (args
[n
]))
1638 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
1641 else if (STRINGP (args
[n
]))
1644 if (*format
!= 's' && *format
!= 'S')
1645 error ("format specifier doesn't match argument type");
1646 total
+= XSTRING (args
[n
])->size
;
1648 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1649 else if (INTEGERP (args
[n
]) && *format
!= 's')
1651 #ifdef LISP_FLOAT_TYPE
1652 /* The following loop assumes the Lisp type indicates
1653 the proper way to pass the argument.
1654 So make sure we have a flonum if the argument should
1656 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1657 args
[n
] = Ffloat (args
[n
]);
1661 #ifdef LISP_FLOAT_TYPE
1662 else if (FLOATP (args
[n
]) && *format
!= 's')
1664 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1665 args
[n
] = Ftruncate (args
[n
]);
1671 /* Anything but a string, convert to a string using princ. */
1672 register Lisp_Object tem
;
1673 tem
= Fprin1_to_string (args
[n
], Qt
);
1680 register int nstrings
= n
+ 1;
1682 /* Allocate twice as many strings as we have %-escapes; floats occupy
1683 two slots, and we're not sure how many of those we have. */
1684 register unsigned char **strings
1685 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1689 for (n
= 0; n
< nstrings
; n
++)
1692 strings
[i
++] = (unsigned char *) "";
1693 else if (INTEGERP (args
[n
]))
1694 /* We checked above that the corresponding format effector
1695 isn't %s, which would cause MPV. */
1696 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1697 #ifdef LISP_FLOAT_TYPE
1698 else if (FLOATP (args
[n
]))
1700 union { double d
; int half
[2]; } u
;
1702 u
.d
= XFLOAT (args
[n
])->data
;
1703 strings
[i
++] = (unsigned char *) u
.half
[0];
1704 strings
[i
++] = (unsigned char *) u
.half
[1];
1708 strings
[i
++] = XSTRING (args
[n
])->data
;
1711 /* Format it in bigger and bigger buf's until it all fits. */
1714 buf
= (char *) alloca (total
+ 1);
1717 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1718 if (buf
[total
- 1] == 0)
1726 return make_string (buf
, length
);
1732 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1733 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
1747 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1749 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1751 return build_string (buf
);
1754 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1755 "Return t if two characters match, optionally ignoring case.\n\
1756 Both arguments must be characters (i.e. integers).\n\
1757 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1759 register Lisp_Object c1
, c2
;
1761 unsigned char *downcase
= DOWNCASE_TABLE
;
1762 CHECK_NUMBER (c1
, 0);
1763 CHECK_NUMBER (c2
, 1);
1765 if (!NILP (current_buffer
->case_fold_search
)
1766 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1767 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1768 : XINT (c1
) == XINT (c2
))
1773 /* Transpose the markers in two regions of the current buffer, and
1774 adjust the ones between them if necessary (i.e.: if the regions
1777 Traverses the entire marker list of the buffer to do so, adding an
1778 appropriate amount to some, subtracting from some, and leaving the
1779 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1781 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1784 transpose_markers (start1
, end1
, start2
, end2
)
1785 register int start1
, end1
, start2
, end2
;
1787 register int amt1
, amt2
, diff
, mpos
;
1788 register Lisp_Object marker
;
1790 /* Update point as if it were a marker. */
1794 TEMP_SET_PT (PT
+ (end2
- end1
));
1795 else if (PT
< start2
)
1796 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1798 TEMP_SET_PT (PT
- (start2
- start1
));
1800 /* We used to adjust the endpoints here to account for the gap, but that
1801 isn't good enough. Even if we assume the caller has tried to move the
1802 gap out of our way, it might still be at start1 exactly, for example;
1803 and that places it `inside' the interval, for our purposes. The amount
1804 of adjustment is nontrivial if there's a `denormalized' marker whose
1805 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1806 the dirty work to Fmarker_position, below. */
1808 /* The difference between the region's lengths */
1809 diff
= (end2
- start2
) - (end1
- start1
);
1811 /* For shifting each marker in a region by the length of the other
1812 * region plus the distance between the regions.
1814 amt1
= (end2
- start2
) + (start2
- end1
);
1815 amt2
= (end1
- start1
) + (start2
- end1
);
1817 for (marker
= current_buffer
->markers
; !NILP (marker
);
1818 marker
= XMARKER (marker
)->chain
)
1820 mpos
= Fmarker_position (marker
);
1821 if (mpos
>= start1
&& mpos
< end2
)
1825 else if (mpos
< start2
)
1829 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1830 XMARKER (marker
)->bufpos
= mpos
;
1835 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1836 "Transpose region START1 to END1 with START2 to END2.\n\
1837 The regions may not be overlapping, because the size of the buffer is\n\
1838 never changed in a transposition.\n\
1840 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1841 any markers that happen to be located in the regions.\n\
1843 Transposing beyond buffer boundaries is an error.")
1844 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1845 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1847 register int start1
, end1
, start2
, end2
,
1848 gap
, len1
, len_mid
, len2
;
1849 unsigned char *start1_addr
, *start2_addr
, *temp
;
1851 #ifdef USE_TEXT_PROPERTIES
1852 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1853 cur_intv
= current_buffer
->intervals
;
1854 #endif /* USE_TEXT_PROPERTIES */
1856 validate_region (&startr1
, &endr1
);
1857 validate_region (&startr2
, &endr2
);
1859 start1
= XFASTINT (startr1
);
1860 end1
= XFASTINT (endr1
);
1861 start2
= XFASTINT (startr2
);
1862 end2
= XFASTINT (endr2
);
1865 /* Swap the regions if they're reversed. */
1868 register int glumph
= start1
;
1876 len1
= end1
- start1
;
1877 len2
= end2
- start2
;
1880 error ("transposed regions not properly ordered");
1881 else if (start1
== end1
|| start2
== end2
)
1882 error ("transposed region may not be of length 0");
1884 /* The possibilities are:
1885 1. Adjacent (contiguous) regions, or separate but equal regions
1886 (no, really equal, in this case!), or
1887 2. Separate regions of unequal size.
1889 The worst case is usually No. 2. It means that (aside from
1890 potential need for getting the gap out of the way), there also
1891 needs to be a shifting of the text between the two regions. So
1892 if they are spread far apart, we are that much slower... sigh. */
1894 /* It must be pointed out that the really studly thing to do would
1895 be not to move the gap at all, but to leave it in place and work
1896 around it if necessary. This would be extremely efficient,
1897 especially considering that people are likely to do
1898 transpositions near where they are working interactively, which
1899 is exactly where the gap would be found. However, such code
1900 would be much harder to write and to read. So, if you are
1901 reading this comment and are feeling squirrely, by all means have
1902 a go! I just didn't feel like doing it, so I will simply move
1903 the gap the minimum distance to get it out of the way, and then
1904 deal with an unbroken array. */
1906 /* Make sure the gap won't interfere, by moving it out of the text
1907 we will operate on. */
1908 if (start1
< gap
&& gap
< end2
)
1910 if (gap
- start1
< end2
- gap
)
1916 /* Hmmm... how about checking to see if the gap is large
1917 enough to use as the temporary storage? That would avoid an
1918 allocation... interesting. Later, don't fool with it now. */
1920 /* Working without memmove, for portability (sigh), so must be
1921 careful of overlapping subsections of the array... */
1923 if (end1
== start2
) /* adjacent regions */
1925 modify_region (current_buffer
, start1
, end2
);
1926 record_change (start1
, len1
+ len2
);
1928 #ifdef USE_TEXT_PROPERTIES
1929 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1930 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1931 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1932 #endif /* USE_TEXT_PROPERTIES */
1934 /* First region smaller than second. */
1937 /* We use alloca only if it is small,
1938 because we want to avoid stack overflow. */
1940 temp
= (unsigned char *) xmalloc (len2
);
1942 temp
= (unsigned char *) alloca (len2
);
1944 /* Don't precompute these addresses. We have to compute them
1945 at the last minute, because the relocating allocator might
1946 have moved the buffer around during the xmalloc. */
1947 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1948 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1950 bcopy (start2_addr
, temp
, len2
);
1951 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1952 bcopy (temp
, start1_addr
, len2
);
1957 /* First region not smaller than second. */
1960 temp
= (unsigned char *) xmalloc (len1
);
1962 temp
= (unsigned char *) alloca (len1
);
1963 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1964 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1965 bcopy (start1_addr
, temp
, len1
);
1966 bcopy (start2_addr
, start1_addr
, len2
);
1967 bcopy (temp
, start1_addr
+ len2
, len1
);
1971 #ifdef USE_TEXT_PROPERTIES
1972 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1973 len1
, current_buffer
, 0);
1974 graft_intervals_into_buffer (tmp_interval2
, start1
,
1975 len2
, current_buffer
, 0);
1976 #endif /* USE_TEXT_PROPERTIES */
1978 /* Non-adjacent regions, because end1 != start2, bleagh... */
1982 /* Regions are same size, though, how nice. */
1984 modify_region (current_buffer
, start1
, end1
);
1985 modify_region (current_buffer
, start2
, end2
);
1986 record_change (start1
, len1
);
1987 record_change (start2
, len2
);
1988 #ifdef USE_TEXT_PROPERTIES
1989 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1990 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1991 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
1992 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
1993 #endif /* USE_TEXT_PROPERTIES */
1996 temp
= (unsigned char *) xmalloc (len1
);
1998 temp
= (unsigned char *) alloca (len1
);
1999 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2000 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2001 bcopy (start1_addr
, temp
, len1
);
2002 bcopy (start2_addr
, start1_addr
, len2
);
2003 bcopy (temp
, start2_addr
, len1
);
2006 #ifdef USE_TEXT_PROPERTIES
2007 graft_intervals_into_buffer (tmp_interval1
, start2
,
2008 len1
, current_buffer
, 0);
2009 graft_intervals_into_buffer (tmp_interval2
, start1
,
2010 len2
, current_buffer
, 0);
2011 #endif /* USE_TEXT_PROPERTIES */
2014 else if (len1
< len2
) /* Second region larger than first */
2015 /* Non-adjacent & unequal size, area between must also be shifted. */
2017 len_mid
= start2
- end1
;
2018 modify_region (current_buffer
, start1
, end2
);
2019 record_change (start1
, (end2
- start1
));
2020 #ifdef USE_TEXT_PROPERTIES
2021 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2022 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2023 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2024 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2025 #endif /* USE_TEXT_PROPERTIES */
2027 /* holds region 2 */
2029 temp
= (unsigned char *) xmalloc (len2
);
2031 temp
= (unsigned char *) alloca (len2
);
2032 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2033 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2034 bcopy (start2_addr
, temp
, len2
);
2035 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
2036 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2037 bcopy (temp
, start1_addr
, len2
);
2040 #ifdef USE_TEXT_PROPERTIES
2041 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2042 len1
, current_buffer
, 0);
2043 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2044 len_mid
, current_buffer
, 0);
2045 graft_intervals_into_buffer (tmp_interval2
, start1
,
2046 len2
, current_buffer
, 0);
2047 #endif /* USE_TEXT_PROPERTIES */
2050 /* Second region smaller than first. */
2052 len_mid
= start2
- end1
;
2053 record_change (start1
, (end2
- start1
));
2054 modify_region (current_buffer
, start1
, end2
);
2056 #ifdef USE_TEXT_PROPERTIES
2057 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2058 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2059 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2060 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2061 #endif /* USE_TEXT_PROPERTIES */
2063 /* holds region 1 */
2065 temp
= (unsigned char *) xmalloc (len1
);
2067 temp
= (unsigned char *) alloca (len1
);
2068 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2069 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2070 bcopy (start1_addr
, temp
, len1
);
2071 bcopy (start2_addr
, start1_addr
, len2
);
2072 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2073 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
2076 #ifdef USE_TEXT_PROPERTIES
2077 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2078 len1
, current_buffer
, 0);
2079 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2080 len_mid
, current_buffer
, 0);
2081 graft_intervals_into_buffer (tmp_interval2
, start1
,
2082 len2
, current_buffer
, 0);
2083 #endif /* USE_TEXT_PROPERTIES */
2087 /* todo: this will be slow, because for every transposition, we
2088 traverse the whole friggin marker list. Possible solutions:
2089 somehow get a list of *all* the markers across multiple
2090 transpositions and do it all in one swell phoop. Or maybe modify
2091 Emacs' marker code to keep an ordered list or tree. This might
2092 be nicer, and more beneficial in the long run, but would be a
2093 bunch of work. Plus the way they're arranged now is nice. */
2094 if (NILP (leave_markers
))
2096 transpose_markers (start1
, end1
, start2
, end2
);
2097 fix_overlays_in_range (start1
, end2
);
2107 DEFVAR_LISP ("system-name", &Vsystem_name
,
2108 "The name of the machine Emacs is running on.");
2110 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2111 "The full name of the user logged in.");
2113 DEFVAR_LISP ("user-name", &Vuser_name
,
2114 "The user's name, taken from environment variables if possible.");
2116 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
2117 "The user's name, based upon the real uid only.");
2119 defsubr (&Schar_equal
);
2120 defsubr (&Sgoto_char
);
2121 defsubr (&Sstring_to_char
);
2122 defsubr (&Schar_to_string
);
2123 defsubr (&Sbuffer_substring
);
2124 defsubr (&Sbuffer_string
);
2126 defsubr (&Spoint_marker
);
2127 defsubr (&Smark_marker
);
2129 defsubr (&Sregion_beginning
);
2130 defsubr (&Sregion_end
);
2131 /* defsubr (&Smark); */
2132 /* defsubr (&Sset_mark); */
2133 defsubr (&Ssave_excursion
);
2135 defsubr (&Sbufsize
);
2136 defsubr (&Spoint_max
);
2137 defsubr (&Spoint_min
);
2138 defsubr (&Spoint_min_marker
);
2139 defsubr (&Spoint_max_marker
);
2145 defsubr (&Sfollowing_char
);
2146 defsubr (&Sprevious_char
);
2147 defsubr (&Schar_after
);
2149 defsubr (&Sinsert_before_markers
);
2150 defsubr (&Sinsert_and_inherit
);
2151 defsubr (&Sinsert_and_inherit_before_markers
);
2152 defsubr (&Sinsert_char
);
2154 defsubr (&Suser_login_name
);
2155 defsubr (&Suser_real_login_name
);
2156 defsubr (&Suser_uid
);
2157 defsubr (&Suser_real_uid
);
2158 defsubr (&Suser_full_name
);
2159 defsubr (&Semacs_pid
);
2160 defsubr (&Scurrent_time
);
2161 defsubr (&Sformat_time_string
);
2162 defsubr (&Scurrent_time_string
);
2163 defsubr (&Scurrent_time_zone
);
2164 defsubr (&Ssystem_name
);
2165 defsubr (&Smessage
);
2166 defsubr (&Smessage_box
);
2167 defsubr (&Smessage_or_box
);
2170 defsubr (&Sinsert_buffer_substring
);
2171 defsubr (&Scompare_buffer_substrings
);
2172 defsubr (&Ssubst_char_in_region
);
2173 defsubr (&Stranslate_region
);
2174 defsubr (&Sdelete_region
);
2176 defsubr (&Snarrow_to_region
);
2177 defsubr (&Ssave_restriction
);
2178 defsubr (&Stranspose_regions
);