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 XSETFASTINT (val
, ((unsigned char *) p
->data
)[0]);
133 XSETFASTINT (val
, 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 XSETFASTINT (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 XSETFASTINT (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 XSETFASTINT (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 XSETFASTINT (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.")
409 XSETFASTINT (temp
, 0);
411 XSETFASTINT (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.")
422 XSETFASTINT (temp
, 0);
424 XSETFASTINT (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 XSETFASTINT (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.")
493 /* Set up the user name info if we didn't do it before.
494 (That can happen if Emacs is dumpable
495 but you decide to run `temacs -l loadup' and not dump. */
496 if (INTEGERP (Vuser_name
))
501 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
503 "Return the name of the user's real uid, as a string.\n\
504 This ignores the environment variables LOGNAME and USER, so it differs from\n\
505 `user-login-name' when running under `su'.")
508 /* Set up the user name info if we didn't do it before.
509 (That can happen if Emacs is dumpable
510 but you decide to run `temacs -l loadup' and not dump. */
511 if (INTEGERP (Vuser_name
))
513 return Vuser_real_name
;
516 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
517 "Return the effective uid of Emacs, as an integer.")
520 return make_number (geteuid ());
523 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
524 "Return the real uid of Emacs, as an integer.")
527 return make_number (getuid ());
530 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
531 "Return the full name of the user logged in, as a string.")
534 return Vuser_full_name
;
537 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
538 "Return the name of the machine you are running on, as a string.")
544 /* For the benefit of callers who don't want to include lisp.h */
548 return (char *) XSTRING (Vsystem_name
)->data
;
551 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
552 "Return the process ID of Emacs, as an integer.")
555 return make_number (getpid ());
558 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
559 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
560 The time is returned as a list of three integers. The first has the\n\
561 most significant 16 bits of the seconds, while the second has the\n\
562 least significant 16 bits. The third integer gives the microsecond\n\
565 The microsecond count is zero on systems that do not provide\n\
566 resolution finer than a second.")
570 Lisp_Object result
[3];
573 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
574 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
575 XSETINT (result
[2], EMACS_USECS (t
));
577 return Flist (3, result
);
582 lisp_time_argument (specified_time
, result
)
583 Lisp_Object specified_time
;
586 if (NILP (specified_time
))
587 return time (result
) != -1;
590 Lisp_Object high
, low
;
591 high
= Fcar (specified_time
);
592 CHECK_NUMBER (high
, 0);
593 low
= Fcdr (specified_time
);
596 CHECK_NUMBER (low
, 0);
597 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
598 return *result
>> 16 == XINT (high
);
602 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 2, 2, 0,
603 "Use FORMAT-STRING to format the time TIME.\n\
604 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from\n\
605 `current-time' and `file-attributes'.\n\
606 FORMAT-STRING may contain %-sequences to substitute parts of the time.\n\
607 %a is replaced by the abbreviated name of the day of week.\n\
608 %A is replaced by the full name of the day of week.\n\
609 %b is replaced by the abbreviated name of the month.\n\
610 %B is replaced by the full name of the month.\n\
611 %c is a synonym for \"%x %X\".\n\
612 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.\n\
613 %d is replaced by the day of month, zero-padded.\n\
614 %D is a synonym for \"%m/%d/%y\".\n\
615 %e is replaced by the day of month, blank-padded.\n\
616 %h is a synonym for \"%b\".\n\
617 %H is replaced by the hour (00-23).\n\
618 %I is replaced by the hour (00-12).\n\
619 %j is replaced by the day of the year (001-366).\n\
620 %k is replaced by the hour (0-23), blank padded.\n\
621 %l is replaced by the hour (1-12), blank padded.\n\
622 %m is replaced by the month (01-12).\n\
623 %M is replaced by the minut (00-59).\n\
624 %n is a synonym for \"\\n\".\n\
625 %p is replaced by AM or PM, as appropriate.\n\
626 %r is a synonym for \"%I:%M:%S %p\".\n\
627 %R is a synonym for \"%H:%M\".\n\
628 %S is replaced by the seconds (00-60).\n\
629 %t is a synonym for \"\\t\".\n\
630 %T is a synonym for \"%H:%M:%S\".\n\
631 %U is replaced by the week of the year (01-52), first day of week is Sunday.\n\
632 %w is replaced by the day of week (0-6), Sunday is day 0.\n\
633 %W is replaced by the week of the year (01-52), first day of week is Monday.\n\
634 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.\n\
635 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.\n\
636 %y is replaced by the year without century (00-99).\n\
637 %Y is replaced by the year with century.\n\
638 %Z is replaced by the time zone abbreviation.\n\
640 The number of options reflects the strftime(3) function.")
641 (format_string
, time
)
642 Lisp_Object format_string
, time
;
647 CHECK_STRING (format_string
, 1);
649 if (! lisp_time_argument (time
, &value
))
650 error ("Invalid time specification");
652 /* This is probably enough. */
653 size
= XSTRING (format_string
)->size
* 6 + 50;
657 char *buf
= (char *) alloca (size
);
658 if (strftime (buf
, size
, XSTRING (format_string
)->data
,
660 return build_string (buf
);
661 /* If buffer was too small, make it bigger. */
666 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
667 "Return the current time, as a human-readable string.\n\
668 Programs can use this function to decode a time,\n\
669 since the number of columns in each field is fixed.\n\
670 The format is `Sun Sep 16 01:03:52 1973'.\n\
671 If an argument is given, it specifies a time to format\n\
672 instead of the current time. The argument should have the form:\n\
675 (HIGH LOW . IGNORED).\n\
676 Thus, you can use times obtained from `current-time'\n\
677 and from `file-attributes'.")
679 Lisp_Object specified_time
;
685 if (! lisp_time_argument (specified_time
, &value
))
687 tem
= (char *) ctime (&value
);
689 strncpy (buf
, tem
, 24);
692 return build_string (buf
);
695 #define TM_YEAR_ORIGIN 1900
697 /* Yield A - B, measured in seconds. */
702 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
703 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
704 /* Some compilers can't handle this as a single return statement. */
706 /* difference in day of year */
707 a
->tm_yday
- b
->tm_yday
708 /* + intervening leap days */
709 + ((ay
>> 2) - (by
>> 2))
711 + ((ay
/100 >> 2) - (by
/100 >> 2))
712 /* + difference in years * 365 */
713 + (long)(ay
-by
) * 365
715 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
716 + (a
->tm_min
- b
->tm_min
))
717 + (a
->tm_sec
- b
->tm_sec
));
720 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
721 "Return the offset and name for the local time zone.\n\
722 This returns a list of the form (OFFSET NAME).\n\
723 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
724 A negative value means west of Greenwich.\n\
725 NAME is a string giving the name of the time zone.\n\
726 If an argument is given, it specifies when the time zone offset is determined\n\
727 instead of using the current time. The argument should have the form:\n\
730 (HIGH LOW . IGNORED).\n\
731 Thus, you can use times obtained from `current-time'\n\
732 and from `file-attributes'.\n\
734 Some operating systems cannot provide all this information to Emacs;\n\
735 in this case, `current-time-zone' returns a list containing nil for\n\
736 the data it can't find.")
738 Lisp_Object specified_time
;
743 if (lisp_time_argument (specified_time
, &value
)
744 && (t
= gmtime (&value
)) != 0)
750 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
751 t
= localtime (&value
);
752 offset
= difftm (t
, &gmt
);
756 s
= (char *)t
->tm_zone
;
757 #else /* not HAVE_TM_ZONE */
759 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
760 s
= tzname
[t
->tm_isdst
];
762 #endif /* not HAVE_TM_ZONE */
765 /* No local time zone name is available; use "+-NNNN" instead. */
766 int am
= (offset
< 0 ? -offset
: offset
) / 60;
767 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
770 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
773 return Fmake_list (2, Qnil
);
785 /* Callers passing one argument to Finsert need not gcpro the
786 argument "array", since the only element of the array will
787 not be used after calling insert or insert_from_string, so
788 we don't care if it gets trashed. */
790 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
791 "Insert the arguments, either strings or characters, at point.\n\
792 Point moves forward so that it ends up after the inserted text.\n\
793 Any other markers at the point of insertion remain before the text.")
796 register Lisp_Object
*args
;
799 register Lisp_Object tem
;
802 for (argnum
= 0; argnum
< nargs
; argnum
++)
811 else if (STRINGP (tem
))
813 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
817 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
825 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
827 "Insert the arguments at point, inheriting properties from adjoining text.\n\
828 Point moves forward so that it ends up after the inserted text.\n\
829 Any other markers at the point of insertion remain before the text.")
832 register Lisp_Object
*args
;
835 register Lisp_Object tem
;
838 for (argnum
= 0; argnum
< nargs
; argnum
++)
845 insert_and_inherit (str
, 1);
847 else if (STRINGP (tem
))
849 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
853 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
861 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
862 "Insert strings or characters at point, relocating markers after the text.\n\
863 Point moves forward so that it ends up after the inserted text.\n\
864 Any other markers at the point of insertion also end up after the text.")
867 register Lisp_Object
*args
;
870 register Lisp_Object tem
;
873 for (argnum
= 0; argnum
< nargs
; argnum
++)
880 insert_before_markers (str
, 1);
882 else if (STRINGP (tem
))
884 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
888 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
896 DEFUN ("insert-before-markers-and-inherit",
897 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
899 "Insert text at point, relocating markers and inheriting properties.\n\
900 Point moves forward so that it ends up after the inserted text.\n\
901 Any other markers at the point of insertion also end up after the text.")
904 register Lisp_Object
*args
;
907 register Lisp_Object tem
;
910 for (argnum
= 0; argnum
< nargs
; argnum
++)
917 insert_before_markers_and_inherit (str
, 1);
919 else if (STRINGP (tem
))
921 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
925 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
933 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
934 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
935 Point and all markers are affected as in the function `insert'.\n\
936 Both arguments are required.\n\
937 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
938 from adjoining text, if those properties are sticky.")
939 (chr
, count
, inherit
)
940 Lisp_Object chr
, count
, inherit
;
942 register unsigned char *string
;
946 CHECK_NUMBER (chr
, 0);
947 CHECK_NUMBER (count
, 1);
952 strlen
= min (n
, 256);
953 string
= (unsigned char *) alloca (strlen
);
954 for (i
= 0; i
< strlen
; i
++)
955 string
[i
] = XFASTINT (chr
);
959 insert_and_inherit (string
, strlen
);
961 insert (string
, strlen
);
970 /* Making strings from buffer contents. */
972 /* Return a Lisp_String containing the text of the current buffer from
973 START to END. If text properties are in use and the current buffer
974 has properties in the range specified, the resulting string will also
977 We don't want to use plain old make_string here, because it calls
978 make_uninit_string, which can cause the buffer arena to be
979 compacted. make_string has no way of knowing that the data has
980 been moved, and thus copies the wrong data into the string. This
981 doesn't effect most of the other users of make_string, so it should
982 be left as is. But we should use this function when conjuring
983 buffer substrings. */
986 make_buffer_string (start
, end
)
989 Lisp_Object result
, tem
, tem1
;
991 if (start
< GPT
&& GPT
< end
)
994 result
= make_uninit_string (end
- start
);
995 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
997 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
998 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1000 #ifdef USE_TEXT_PROPERTIES
1001 if (XINT (tem
) != end
|| !NILP (tem1
))
1002 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
1008 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1009 "Return the contents of part of the current buffer as a string.\n\
1010 The two arguments START and END are character positions;\n\
1011 they can be in either order.")
1015 register int beg
, end
;
1017 validate_region (&b
, &e
);
1021 return make_buffer_string (beg
, end
);
1024 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1025 "Return the contents of the current buffer as a string.")
1028 return make_buffer_string (BEGV
, ZV
);
1031 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1033 "Insert before point a substring of the contents of buffer BUFFER.\n\
1034 BUFFER may be a buffer or a buffer name.\n\
1035 Arguments START and END are character numbers specifying the substring.\n\
1036 They default to the beginning and the end of BUFFER.")
1038 Lisp_Object buf
, b
, e
;
1040 register int beg
, end
, temp
, len
, opoint
, start
;
1041 register struct buffer
*bp
;
1044 buffer
= Fget_buffer (buf
);
1047 bp
= XBUFFER (buffer
);
1050 beg
= BUF_BEGV (bp
);
1053 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1060 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1065 temp
= beg
, beg
= end
, end
= temp
;
1067 /* Move the gap or create enough gap in the current buffer. */
1071 if (GAP_SIZE
< end
- beg
)
1072 make_gap (end
- beg
- GAP_SIZE
);
1078 if (!(BUF_BEGV (bp
) <= beg
1080 && end
<= BUF_ZV (bp
)))
1081 args_out_of_range (b
, e
);
1083 /* Now the actual insertion will not do any gap motion,
1084 so it matters not if BUF is the current buffer. */
1085 if (beg
< BUF_GPT (bp
))
1087 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
1088 beg
= min (end
, BUF_GPT (bp
));
1091 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1093 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1094 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1095 opoint
, len
, current_buffer
, 0);
1100 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1102 "Compare two substrings of two buffers; return result as number.\n\
1103 the value is -N if first string is less after N-1 chars,\n\
1104 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1105 Each substring is represented as three arguments: BUFFER, START and END.\n\
1106 That makes six args in all, three for each substring.\n\n\
1107 The value of `case-fold-search' in the current buffer\n\
1108 determines whether case is significant or ignored.")
1109 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1110 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1112 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1113 register struct buffer
*bp1
, *bp2
;
1114 register unsigned char *trt
1115 = (!NILP (current_buffer
->case_fold_search
)
1116 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1118 /* Find the first buffer and its substring. */
1121 bp1
= current_buffer
;
1125 buf1
= Fget_buffer (buffer1
);
1128 bp1
= XBUFFER (buf1
);
1132 begp1
= BUF_BEGV (bp1
);
1135 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1136 begp1
= XINT (start1
);
1139 endp1
= BUF_ZV (bp1
);
1142 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1143 endp1
= XINT (end1
);
1147 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1149 if (!(BUF_BEGV (bp1
) <= begp1
1151 && endp1
<= BUF_ZV (bp1
)))
1152 args_out_of_range (start1
, end1
);
1154 /* Likewise for second substring. */
1157 bp2
= current_buffer
;
1161 buf2
= Fget_buffer (buffer2
);
1164 bp2
= XBUFFER (buffer2
);
1168 begp2
= BUF_BEGV (bp2
);
1171 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1172 begp2
= XINT (start2
);
1175 endp2
= BUF_ZV (bp2
);
1178 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1179 endp2
= XINT (end2
);
1183 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1185 if (!(BUF_BEGV (bp2
) <= begp2
1187 && endp2
<= BUF_ZV (bp2
)))
1188 args_out_of_range (start2
, end2
);
1190 len1
= endp1
- begp1
;
1191 len2
= endp2
- begp2
;
1196 for (i
= 0; i
< length
; i
++)
1198 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1199 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1206 return make_number (- 1 - i
);
1208 return make_number (i
+ 1);
1211 /* The strings match as far as they go.
1212 If one is shorter, that one is less. */
1214 return make_number (length
+ 1);
1215 else if (length
< len2
)
1216 return make_number (- length
- 1);
1218 /* Same length too => they are equal. */
1219 return make_number (0);
1222 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1223 Ssubst_char_in_region
, 4, 5, 0,
1224 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1225 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1226 and don't mark the buffer as really changed.")
1227 (start
, end
, fromchar
, tochar
, noundo
)
1228 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1230 register int pos
, stop
, look
;
1233 validate_region (&start
, &end
);
1234 CHECK_NUMBER (fromchar
, 2);
1235 CHECK_NUMBER (tochar
, 3);
1239 look
= XINT (fromchar
);
1243 if (FETCH_CHAR (pos
) == look
)
1247 modify_region (current_buffer
, XINT (start
), stop
);
1249 if (! NILP (noundo
))
1251 if (MODIFF
- 1 == current_buffer
->save_modified
)
1252 current_buffer
->save_modified
++;
1253 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1254 current_buffer
->auto_save_modified
++;
1261 record_change (pos
, 1);
1262 FETCH_CHAR (pos
) = XINT (tochar
);
1268 signal_after_change (XINT (start
),
1269 stop
- XINT (start
), stop
- XINT (start
));
1274 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1275 "From START to END, translate characters according to TABLE.\n\
1276 TABLE is a string; the Nth character in it is the mapping\n\
1277 for the character with code N. Returns the number of characters changed.")
1281 register Lisp_Object table
;
1283 register int pos
, stop
; /* Limits of the region. */
1284 register unsigned char *tt
; /* Trans table. */
1285 register int oc
; /* Old character. */
1286 register int nc
; /* New character. */
1287 int cnt
; /* Number of changes made. */
1288 Lisp_Object z
; /* Return. */
1289 int size
; /* Size of translate table. */
1291 validate_region (&start
, &end
);
1292 CHECK_STRING (table
, 2);
1294 size
= XSTRING (table
)->size
;
1295 tt
= XSTRING (table
)->data
;
1299 modify_region (current_buffer
, pos
, stop
);
1302 for (; pos
< stop
; ++pos
)
1304 oc
= FETCH_CHAR (pos
);
1310 record_change (pos
, 1);
1311 FETCH_CHAR (pos
) = nc
;
1312 signal_after_change (pos
, 1, 1);
1318 XSETFASTINT (z
, cnt
);
1322 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1323 "Delete the text between point and mark.\n\
1324 When called from a program, expects two arguments,\n\
1325 positions (integers or markers) specifying the stretch to be deleted.")
1329 validate_region (&b
, &e
);
1330 del_range (XINT (b
), XINT (e
));
1334 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1335 "Remove restrictions (narrowing) from current buffer.\n\
1336 This allows the buffer's full text to be seen and edited.")
1340 SET_BUF_ZV (current_buffer
, Z
);
1342 /* Changing the buffer bounds invalidates any recorded current column. */
1343 invalidate_current_column ();
1347 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1348 "Restrict editing in this buffer to the current region.\n\
1349 The rest of the text becomes temporarily invisible and untouchable\n\
1350 but is not deleted; if you save the buffer in a file, the invisible\n\
1351 text is included in the file. \\[widen] makes all visible again.\n\
1352 See also `save-restriction'.\n\
1354 When calling from a program, pass two arguments; positions (integers\n\
1355 or markers) bounding the text that should remain visible.")
1357 register Lisp_Object b
, e
;
1359 register EMACS_INT i
;
1361 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1362 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1364 if (XINT (b
) > XINT (e
))
1371 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1372 args_out_of_range (b
, e
);
1374 BEGV
= XFASTINT (b
);
1375 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1376 if (point
< XFASTINT (b
))
1377 SET_PT (XFASTINT (b
));
1378 if (point
> XFASTINT (e
))
1379 SET_PT (XFASTINT (e
));
1381 /* Changing the buffer bounds invalidates any recorded current column. */
1382 invalidate_current_column ();
1387 save_restriction_save ()
1389 register Lisp_Object bottom
, top
;
1390 /* Note: I tried using markers here, but it does not win
1391 because insertion at the end of the saved region
1392 does not advance mh and is considered "outside" the saved region. */
1393 XSETFASTINT (bottom
, BEGV
- BEG
);
1394 XSETFASTINT (top
, Z
- ZV
);
1396 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1400 save_restriction_restore (data
)
1403 register struct buffer
*buf
;
1404 register int newhead
, newtail
;
1405 register Lisp_Object tem
;
1407 buf
= XBUFFER (XCONS (data
)->car
);
1409 data
= XCONS (data
)->cdr
;
1411 tem
= XCONS (data
)->car
;
1412 newhead
= XINT (tem
);
1413 tem
= XCONS (data
)->cdr
;
1414 newtail
= XINT (tem
);
1415 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1420 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1421 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1424 /* If point is outside the new visible range, move it inside. */
1426 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1431 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1432 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1433 The buffer's restrictions make parts of the beginning and end invisible.\n\
1434 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1435 This special form, `save-restriction', saves the current buffer's restrictions\n\
1436 when it is entered, and restores them when it is exited.\n\
1437 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1438 The old restrictions settings are restored\n\
1439 even in case of abnormal exit (throw or error).\n\
1441 The value returned is the value of the last form in BODY.\n\
1443 `save-restriction' can get confused if, within the BODY, you widen\n\
1444 and then make changes outside the area within the saved restrictions.\n\
1446 Note: if you are using both `save-excursion' and `save-restriction',\n\
1447 use `save-excursion' outermost:\n\
1448 (save-excursion (save-restriction ...))")
1452 register Lisp_Object val
;
1453 int count
= specpdl_ptr
- specpdl
;
1455 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1456 val
= Fprogn (body
);
1457 return unbind_to (count
, val
);
1460 /* Buffer for the most recent text displayed by Fmessage. */
1461 static char *message_text
;
1463 /* Allocated length of that buffer. */
1464 static int message_length
;
1466 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1467 "Print a one-line message at the bottom of the screen.\n\
1468 The first argument is a control string.\n\
1469 It may contain %s or %d or %c to print successive following arguments.\n\
1470 %s means print an argument as a string, %d means print as number in decimal,\n\
1471 %c means print a number as a single character.\n\
1472 The argument used by %s must be a string or a symbol;\n\
1473 the argument used by %d or %c must be a number.\n\
1474 If the first argument is nil, clear any existing message; let the\n\
1475 minibuffer contents show.")
1487 register Lisp_Object val
;
1488 val
= Fformat (nargs
, args
);
1489 /* Copy the data so that it won't move when we GC. */
1492 message_text
= (char *)xmalloc (80);
1493 message_length
= 80;
1495 if (XSTRING (val
)->size
> message_length
)
1497 message_length
= XSTRING (val
)->size
;
1498 message_text
= (char *)xrealloc (message_text
, message_length
);
1500 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1501 message2 (message_text
, XSTRING (val
)->size
);
1506 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
1507 "Display a message, in a dialog box if possible.\n\
1508 If a dialog box is not available, use the echo area.\n\
1509 The first argument is a control string.\n\
1510 It may contain %s or %d or %c to print successive following arguments.\n\
1511 %s means print an argument as a string, %d means print as number in decimal,\n\
1512 %c means print a number as a single character.\n\
1513 The argument used by %s must be a string or a symbol;\n\
1514 the argument used by %d or %c must be a number.\n\
1515 If the first argument is nil, clear any existing message; let the\n\
1516 minibuffer contents show.")
1528 register Lisp_Object val
;
1529 val
= Fformat (nargs
, args
);
1532 Lisp_Object pane
, menu
, obj
;
1533 struct gcpro gcpro1
;
1534 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
1536 menu
= Fcons (val
, pane
);
1537 obj
= Fx_popup_dialog (Qt
, menu
);
1542 /* Copy the data so that it won't move when we GC. */
1545 message_text
= (char *)xmalloc (80);
1546 message_length
= 80;
1548 if (XSTRING (val
)->size
> message_length
)
1550 message_length
= XSTRING (val
)->size
;
1551 message_text
= (char *)xrealloc (message_text
, message_length
);
1553 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1554 message2 (message_text
, XSTRING (val
)->size
);
1560 extern Lisp_Object last_nonmenu_event
;
1562 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
1563 "Display a message in a dialog box or in the echo area.\n\
1564 If this command was invoked with the mouse, use a dialog box.\n\
1565 Otherwise, use the echo area.\n\
1567 The first argument is a control string.\n\
1568 It may contain %s or %d or %c to print successive following arguments.\n\
1569 %s means print an argument as a string, %d means print as number in decimal,\n\
1570 %c means print a number as a single character.\n\
1571 The argument used by %s must be a string or a symbol;\n\
1572 the argument used by %d or %c must be a number.\n\
1573 If the first argument is nil, clear any existing message; let the\n\
1574 minibuffer contents show.")
1580 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1581 return Fmessage_box (nargs
, args
);
1583 return Fmessage (nargs
, args
);
1586 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1587 "Format a string out of a control-string and arguments.\n\
1588 The first argument is a control string.\n\
1589 The other arguments are substituted into it to make the result, a string.\n\
1590 It may contain %-sequences meaning to substitute the next argument.\n\
1591 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1592 %d means print as number in decimal (%o octal, %x hex).\n\
1593 %c means print a number as a single character.\n\
1594 %S means print any object as an s-expression (using prin1).\n\
1595 The argument used for %d, %o, %x or %c must be a number.\n\
1596 Use %% to put a single % into the output.")
1599 register Lisp_Object
*args
;
1601 register int n
; /* The number of the next arg to substitute */
1602 register int total
= 5; /* An estimate of the final length */
1604 register unsigned char *format
, *end
;
1606 extern char *index ();
1607 /* It should not be necessary to GCPRO ARGS, because
1608 the caller in the interpreter should take care of that. */
1610 CHECK_STRING (args
[0], 0);
1611 format
= XSTRING (args
[0])->data
;
1612 end
= format
+ XSTRING (args
[0])->size
;
1615 while (format
!= end
)
1616 if (*format
++ == '%')
1620 /* Process a numeric arg and skip it. */
1621 minlen
= atoi (format
);
1626 while ((*format
>= '0' && *format
<= '9')
1627 || *format
== '-' || *format
== ' ' || *format
== '.')
1632 else if (++n
>= nargs
)
1633 error ("not enough arguments for format string");
1634 else if (*format
== 'S')
1636 /* For `S', prin1 the argument and then treat like a string. */
1637 register Lisp_Object tem
;
1638 tem
= Fprin1_to_string (args
[n
], Qnil
);
1642 else if (SYMBOLP (args
[n
]))
1644 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
1647 else if (STRINGP (args
[n
]))
1650 if (*format
!= 's' && *format
!= 'S')
1651 error ("format specifier doesn't match argument type");
1652 total
+= XSTRING (args
[n
])->size
;
1654 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1655 else if (INTEGERP (args
[n
]) && *format
!= 's')
1657 #ifdef LISP_FLOAT_TYPE
1658 /* The following loop assumes the Lisp type indicates
1659 the proper way to pass the argument.
1660 So make sure we have a flonum if the argument should
1662 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1663 args
[n
] = Ffloat (args
[n
]);
1667 #ifdef LISP_FLOAT_TYPE
1668 else if (FLOATP (args
[n
]) && *format
!= 's')
1670 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1671 args
[n
] = Ftruncate (args
[n
]);
1677 /* Anything but a string, convert to a string using princ. */
1678 register Lisp_Object tem
;
1679 tem
= Fprin1_to_string (args
[n
], Qt
);
1686 register int nstrings
= n
+ 1;
1688 /* Allocate twice as many strings as we have %-escapes; floats occupy
1689 two slots, and we're not sure how many of those we have. */
1690 register unsigned char **strings
1691 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1695 for (n
= 0; n
< nstrings
; n
++)
1698 strings
[i
++] = (unsigned char *) "";
1699 else if (INTEGERP (args
[n
]))
1700 /* We checked above that the corresponding format effector
1701 isn't %s, which would cause MPV. */
1702 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1703 #ifdef LISP_FLOAT_TYPE
1704 else if (FLOATP (args
[n
]))
1706 union { double d
; int half
[2]; } u
;
1708 u
.d
= XFLOAT (args
[n
])->data
;
1709 strings
[i
++] = (unsigned char *) u
.half
[0];
1710 strings
[i
++] = (unsigned char *) u
.half
[1];
1714 strings
[i
++] = XSTRING (args
[n
])->data
;
1717 /* Format it in bigger and bigger buf's until it all fits. */
1720 buf
= (char *) alloca (total
+ 1);
1723 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1724 if (buf
[total
- 1] == 0)
1732 return make_string (buf
, length
);
1738 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1739 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
1753 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1755 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1757 return build_string (buf
);
1760 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1761 "Return t if two characters match, optionally ignoring case.\n\
1762 Both arguments must be characters (i.e. integers).\n\
1763 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1765 register Lisp_Object c1
, c2
;
1767 unsigned char *downcase
= DOWNCASE_TABLE
;
1768 CHECK_NUMBER (c1
, 0);
1769 CHECK_NUMBER (c2
, 1);
1771 if (!NILP (current_buffer
->case_fold_search
)
1772 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1773 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1774 : XINT (c1
) == XINT (c2
))
1779 /* Transpose the markers in two regions of the current buffer, and
1780 adjust the ones between them if necessary (i.e.: if the regions
1783 Traverses the entire marker list of the buffer to do so, adding an
1784 appropriate amount to some, subtracting from some, and leaving the
1785 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1787 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1790 transpose_markers (start1
, end1
, start2
, end2
)
1791 register int start1
, end1
, start2
, end2
;
1793 register int amt1
, amt2
, diff
, mpos
;
1794 register Lisp_Object marker
;
1796 /* Update point as if it were a marker. */
1800 TEMP_SET_PT (PT
+ (end2
- end1
));
1801 else if (PT
< start2
)
1802 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1804 TEMP_SET_PT (PT
- (start2
- start1
));
1806 /* We used to adjust the endpoints here to account for the gap, but that
1807 isn't good enough. Even if we assume the caller has tried to move the
1808 gap out of our way, it might still be at start1 exactly, for example;
1809 and that places it `inside' the interval, for our purposes. The amount
1810 of adjustment is nontrivial if there's a `denormalized' marker whose
1811 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1812 the dirty work to Fmarker_position, below. */
1814 /* The difference between the region's lengths */
1815 diff
= (end2
- start2
) - (end1
- start1
);
1817 /* For shifting each marker in a region by the length of the other
1818 * region plus the distance between the regions.
1820 amt1
= (end2
- start2
) + (start2
- end1
);
1821 amt2
= (end1
- start1
) + (start2
- end1
);
1823 for (marker
= current_buffer
->markers
; !NILP (marker
);
1824 marker
= XMARKER (marker
)->chain
)
1826 mpos
= Fmarker_position (marker
);
1827 if (mpos
>= start1
&& mpos
< end2
)
1831 else if (mpos
< start2
)
1835 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1836 XMARKER (marker
)->bufpos
= mpos
;
1841 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1842 "Transpose region START1 to END1 with START2 to END2.\n\
1843 The regions may not be overlapping, because the size of the buffer is\n\
1844 never changed in a transposition.\n\
1846 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1847 any markers that happen to be located in the regions.\n\
1849 Transposing beyond buffer boundaries is an error.")
1850 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1851 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1853 register int start1
, end1
, start2
, end2
,
1854 gap
, len1
, len_mid
, len2
;
1855 unsigned char *start1_addr
, *start2_addr
, *temp
;
1857 #ifdef USE_TEXT_PROPERTIES
1858 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1859 cur_intv
= current_buffer
->intervals
;
1860 #endif /* USE_TEXT_PROPERTIES */
1862 validate_region (&startr1
, &endr1
);
1863 validate_region (&startr2
, &endr2
);
1865 start1
= XFASTINT (startr1
);
1866 end1
= XFASTINT (endr1
);
1867 start2
= XFASTINT (startr2
);
1868 end2
= XFASTINT (endr2
);
1871 /* Swap the regions if they're reversed. */
1874 register int glumph
= start1
;
1882 len1
= end1
- start1
;
1883 len2
= end2
- start2
;
1886 error ("transposed regions not properly ordered");
1887 else if (start1
== end1
|| start2
== end2
)
1888 error ("transposed region may not be of length 0");
1890 /* The possibilities are:
1891 1. Adjacent (contiguous) regions, or separate but equal regions
1892 (no, really equal, in this case!), or
1893 2. Separate regions of unequal size.
1895 The worst case is usually No. 2. It means that (aside from
1896 potential need for getting the gap out of the way), there also
1897 needs to be a shifting of the text between the two regions. So
1898 if they are spread far apart, we are that much slower... sigh. */
1900 /* It must be pointed out that the really studly thing to do would
1901 be not to move the gap at all, but to leave it in place and work
1902 around it if necessary. This would be extremely efficient,
1903 especially considering that people are likely to do
1904 transpositions near where they are working interactively, which
1905 is exactly where the gap would be found. However, such code
1906 would be much harder to write and to read. So, if you are
1907 reading this comment and are feeling squirrely, by all means have
1908 a go! I just didn't feel like doing it, so I will simply move
1909 the gap the minimum distance to get it out of the way, and then
1910 deal with an unbroken array. */
1912 /* Make sure the gap won't interfere, by moving it out of the text
1913 we will operate on. */
1914 if (start1
< gap
&& gap
< end2
)
1916 if (gap
- start1
< end2
- gap
)
1922 /* Hmmm... how about checking to see if the gap is large
1923 enough to use as the temporary storage? That would avoid an
1924 allocation... interesting. Later, don't fool with it now. */
1926 /* Working without memmove, for portability (sigh), so must be
1927 careful of overlapping subsections of the array... */
1929 if (end1
== start2
) /* adjacent regions */
1931 modify_region (current_buffer
, start1
, end2
);
1932 record_change (start1
, len1
+ len2
);
1934 #ifdef USE_TEXT_PROPERTIES
1935 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1936 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1937 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1938 #endif /* USE_TEXT_PROPERTIES */
1940 /* First region smaller than second. */
1943 /* We use alloca only if it is small,
1944 because we want to avoid stack overflow. */
1946 temp
= (unsigned char *) xmalloc (len2
);
1948 temp
= (unsigned char *) alloca (len2
);
1950 /* Don't precompute these addresses. We have to compute them
1951 at the last minute, because the relocating allocator might
1952 have moved the buffer around during the xmalloc. */
1953 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1954 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1956 bcopy (start2_addr
, temp
, len2
);
1957 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1958 bcopy (temp
, start1_addr
, len2
);
1963 /* First region not smaller than second. */
1966 temp
= (unsigned char *) xmalloc (len1
);
1968 temp
= (unsigned char *) alloca (len1
);
1969 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1970 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1971 bcopy (start1_addr
, temp
, len1
);
1972 bcopy (start2_addr
, start1_addr
, len2
);
1973 bcopy (temp
, start1_addr
+ len2
, len1
);
1977 #ifdef USE_TEXT_PROPERTIES
1978 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1979 len1
, current_buffer
, 0);
1980 graft_intervals_into_buffer (tmp_interval2
, start1
,
1981 len2
, current_buffer
, 0);
1982 #endif /* USE_TEXT_PROPERTIES */
1984 /* Non-adjacent regions, because end1 != start2, bleagh... */
1988 /* Regions are same size, though, how nice. */
1990 modify_region (current_buffer
, start1
, end1
);
1991 modify_region (current_buffer
, start2
, end2
);
1992 record_change (start1
, len1
);
1993 record_change (start2
, len2
);
1994 #ifdef USE_TEXT_PROPERTIES
1995 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1996 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1997 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
1998 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
1999 #endif /* USE_TEXT_PROPERTIES */
2002 temp
= (unsigned char *) xmalloc (len1
);
2004 temp
= (unsigned char *) alloca (len1
);
2005 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2006 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2007 bcopy (start1_addr
, temp
, len1
);
2008 bcopy (start2_addr
, start1_addr
, len2
);
2009 bcopy (temp
, start2_addr
, len1
);
2012 #ifdef USE_TEXT_PROPERTIES
2013 graft_intervals_into_buffer (tmp_interval1
, start2
,
2014 len1
, current_buffer
, 0);
2015 graft_intervals_into_buffer (tmp_interval2
, start1
,
2016 len2
, current_buffer
, 0);
2017 #endif /* USE_TEXT_PROPERTIES */
2020 else if (len1
< len2
) /* Second region larger than first */
2021 /* Non-adjacent & unequal size, area between must also be shifted. */
2023 len_mid
= start2
- end1
;
2024 modify_region (current_buffer
, start1
, end2
);
2025 record_change (start1
, (end2
- start1
));
2026 #ifdef USE_TEXT_PROPERTIES
2027 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2028 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2029 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2030 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2031 #endif /* USE_TEXT_PROPERTIES */
2033 /* holds region 2 */
2035 temp
= (unsigned char *) xmalloc (len2
);
2037 temp
= (unsigned char *) alloca (len2
);
2038 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2039 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2040 bcopy (start2_addr
, temp
, len2
);
2041 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
2042 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2043 bcopy (temp
, start1_addr
, len2
);
2046 #ifdef USE_TEXT_PROPERTIES
2047 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2048 len1
, current_buffer
, 0);
2049 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2050 len_mid
, current_buffer
, 0);
2051 graft_intervals_into_buffer (tmp_interval2
, start1
,
2052 len2
, current_buffer
, 0);
2053 #endif /* USE_TEXT_PROPERTIES */
2056 /* Second region smaller than first. */
2058 len_mid
= start2
- end1
;
2059 record_change (start1
, (end2
- start1
));
2060 modify_region (current_buffer
, start1
, end2
);
2062 #ifdef USE_TEXT_PROPERTIES
2063 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2064 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2065 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2066 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2067 #endif /* USE_TEXT_PROPERTIES */
2069 /* holds region 1 */
2071 temp
= (unsigned char *) xmalloc (len1
);
2073 temp
= (unsigned char *) alloca (len1
);
2074 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2075 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2076 bcopy (start1_addr
, temp
, len1
);
2077 bcopy (start2_addr
, start1_addr
, len2
);
2078 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2079 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
2082 #ifdef USE_TEXT_PROPERTIES
2083 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2084 len1
, current_buffer
, 0);
2085 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2086 len_mid
, current_buffer
, 0);
2087 graft_intervals_into_buffer (tmp_interval2
, start1
,
2088 len2
, current_buffer
, 0);
2089 #endif /* USE_TEXT_PROPERTIES */
2093 /* todo: this will be slow, because for every transposition, we
2094 traverse the whole friggin marker list. Possible solutions:
2095 somehow get a list of *all* the markers across multiple
2096 transpositions and do it all in one swell phoop. Or maybe modify
2097 Emacs' marker code to keep an ordered list or tree. This might
2098 be nicer, and more beneficial in the long run, but would be a
2099 bunch of work. Plus the way they're arranged now is nice. */
2100 if (NILP (leave_markers
))
2102 transpose_markers (start1
, end1
, start2
, end2
);
2103 fix_overlays_in_range (start1
, end2
);
2113 DEFVAR_LISP ("system-name", &Vsystem_name
,
2114 "The name of the machine Emacs is running on.");
2116 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2117 "The full name of the user logged in.");
2119 DEFVAR_LISP ("user-name", &Vuser_name
,
2120 "The user's name, taken from environment variables if possible.");
2122 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
2123 "The user's name, based upon the real uid only.");
2125 defsubr (&Schar_equal
);
2126 defsubr (&Sgoto_char
);
2127 defsubr (&Sstring_to_char
);
2128 defsubr (&Schar_to_string
);
2129 defsubr (&Sbuffer_substring
);
2130 defsubr (&Sbuffer_string
);
2132 defsubr (&Spoint_marker
);
2133 defsubr (&Smark_marker
);
2135 defsubr (&Sregion_beginning
);
2136 defsubr (&Sregion_end
);
2137 /* defsubr (&Smark); */
2138 /* defsubr (&Sset_mark); */
2139 defsubr (&Ssave_excursion
);
2141 defsubr (&Sbufsize
);
2142 defsubr (&Spoint_max
);
2143 defsubr (&Spoint_min
);
2144 defsubr (&Spoint_min_marker
);
2145 defsubr (&Spoint_max_marker
);
2151 defsubr (&Sfollowing_char
);
2152 defsubr (&Sprevious_char
);
2153 defsubr (&Schar_after
);
2155 defsubr (&Sinsert_before_markers
);
2156 defsubr (&Sinsert_and_inherit
);
2157 defsubr (&Sinsert_and_inherit_before_markers
);
2158 defsubr (&Sinsert_char
);
2160 defsubr (&Suser_login_name
);
2161 defsubr (&Suser_real_login_name
);
2162 defsubr (&Suser_uid
);
2163 defsubr (&Suser_real_uid
);
2164 defsubr (&Suser_full_name
);
2165 defsubr (&Semacs_pid
);
2166 defsubr (&Scurrent_time
);
2167 defsubr (&Sformat_time_string
);
2168 defsubr (&Scurrent_time_string
);
2169 defsubr (&Scurrent_time_zone
);
2170 defsubr (&Ssystem_name
);
2171 defsubr (&Smessage
);
2172 defsubr (&Smessage_box
);
2173 defsubr (&Smessage_or_box
);
2176 defsubr (&Sinsert_buffer_substring
);
2177 defsubr (&Scompare_buffer_substrings
);
2178 defsubr (&Ssubst_char_in_region
);
2179 defsubr (&Stranslate_region
);
2180 defsubr (&Sdelete_region
);
2182 defsubr (&Snarrow_to_region
);
2183 defsubr (&Ssave_restriction
);
2184 defsubr (&Stranspose_regions
);