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 ());
68 /* We let the real user name default to "root" because that's quite
69 accurate on MSDOG and because it lets Emacs find the init file.
70 (The DVX libraries override the Djgpp libraries here.) */
71 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "root");
73 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
76 /* Get the effective user name, by consulting environment variables,
77 or the effective uid if those are unset. */
78 user_name
= (char *) getenv ("LOGNAME");
80 user_name
= (char *) getenv ("USER");
83 pw
= (struct passwd
*) getpwuid (geteuid ());
84 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
86 Vuser_name
= build_string (user_name
);
88 /* If the user name claimed in the environment vars differs from
89 the real uid, use the claimed name to find the full name. */
90 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
92 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
94 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
95 q
= (unsigned char *) index (p
, ',');
96 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
98 #ifdef AMPERSAND_FULL_NAME
99 p
= XSTRING (Vuser_full_name
)->data
;
100 q
= (char *) index (p
, '&');
101 /* Substitute the login name for the &, upcasing the first character. */
104 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
107 strcat (r
, XSTRING (Vuser_name
)->data
);
108 r
[q
- p
] = UPCASE (r
[q
- p
]);
110 Vuser_full_name
= build_string (r
);
112 #endif /* AMPERSAND_FULL_NAME */
115 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
116 "Convert arg CHAR to a one-character string containing that character.")
124 return make_string (&c
, 1);
127 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
128 "Convert arg STRING to a character, the first character of that string.")
130 register Lisp_Object str
;
132 register Lisp_Object val
;
133 register struct Lisp_String
*p
;
134 CHECK_STRING (str
, 0);
138 XSETFASTINT (val
, ((unsigned char *) p
->data
)[0]);
140 XSETFASTINT (val
, 0);
148 register Lisp_Object mark
;
149 mark
= Fmake_marker ();
150 Fset_marker (mark
, make_number (val
), Qnil
);
154 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
155 "Return value of point, as an integer.\n\
156 Beginning of buffer is position (point-min)")
160 XSETFASTINT (temp
, point
);
164 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
165 "Return value of point, as a marker object.")
168 return buildmark (point
);
172 clip_to_bounds (lower
, num
, upper
)
173 int lower
, num
, upper
;
177 else if (num
> upper
)
183 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
184 "Set point to POSITION, a number or marker.\n\
185 Beginning of buffer is position (point-min), end is (point-max).")
187 register Lisp_Object n
;
189 CHECK_NUMBER_COERCE_MARKER (n
, 0);
191 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
196 region_limit (beginningp
)
199 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
200 register Lisp_Object m
;
201 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
202 && NILP (current_buffer
->mark_active
))
203 Fsignal (Qmark_inactive
, Qnil
);
204 m
= Fmarker_position (current_buffer
->mark
);
205 if (NILP (m
)) error ("There is no region now");
206 if ((point
< XFASTINT (m
)) == beginningp
)
207 return (make_number (point
));
212 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
213 "Return position of beginning of region, as an integer.")
216 return (region_limit (1));
219 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
220 "Return position of end of region, as an integer.")
223 return (region_limit (0));
226 #if 0 /* now in lisp code */
227 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
228 "Return this buffer's mark value as integer, or nil if no mark.\n\
229 If you are using this in an editing command, you are most likely making\n\
230 a mistake; see the documentation of `set-mark'.")
233 return Fmarker_position (current_buffer
->mark
);
235 #endif /* commented out code */
237 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
238 "Return this buffer's mark, as a marker object.\n\
239 Watch out! Moving this marker changes the mark position.\n\
240 If you set the marker not to point anywhere, the buffer will have no mark.")
243 return current_buffer
->mark
;
246 #if 0 /* this is now in lisp code */
247 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
248 "Set this buffer's mark to POS. Don't use this function!\n\
249 That is to say, don't use this function unless you want\n\
250 the user to see that the mark has moved, and you want the previous\n\
251 mark position to be lost.\n\
253 Normally, when a new mark is set, the old one should go on the stack.\n\
254 This is why most applications should use push-mark, not set-mark.\n\
256 Novice programmers often try to use the mark for the wrong purposes.\n\
257 The mark saves a location for the user's convenience.\n\
258 Most editing commands should not alter the mark.\n\
259 To remember a location for internal use in the Lisp program,\n\
260 store it in a Lisp variable. Example:\n\
262 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
268 current_buffer
->mark
= Qnil
;
271 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
273 if (NILP (current_buffer
->mark
))
274 current_buffer
->mark
= Fmake_marker ();
276 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
279 #endif /* commented-out code */
282 save_excursion_save ()
284 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
287 return Fcons (Fpoint_marker (),
288 Fcons (Fcopy_marker (current_buffer
->mark
),
289 Fcons (visible
? Qt
: Qnil
,
290 current_buffer
->mark_active
)));
294 save_excursion_restore (info
)
295 register Lisp_Object info
;
297 register Lisp_Object tem
, tem1
, omark
, nmark
;
299 tem
= Fmarker_buffer (Fcar (info
));
300 /* If buffer being returned to is now deleted, avoid error */
301 /* Otherwise could get error here while unwinding to top level
303 /* In that case, Fmarker_buffer returns nil now. */
309 unchain_marker (tem
);
310 tem
= Fcar (Fcdr (info
));
311 omark
= Fmarker_position (current_buffer
->mark
);
312 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
313 nmark
= Fmarker_position (tem
);
314 unchain_marker (tem
);
315 tem
= Fcdr (Fcdr (info
));
316 #if 0 /* We used to make the current buffer visible in the selected window
317 if that was true previously. That avoids some anomalies.
318 But it creates others, and it wasn't documented, and it is simpler
319 and cleaner never to alter the window/buffer connections. */
322 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
323 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
326 tem1
= current_buffer
->mark_active
;
327 current_buffer
->mark_active
= Fcdr (tem
);
328 if (!NILP (Vrun_hooks
))
330 /* If mark is active now, and either was not active
331 or was at a different place, run the activate hook. */
332 if (! NILP (current_buffer
->mark_active
))
334 if (! EQ (omark
, nmark
))
335 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
337 /* If mark has ceased to be active, run deactivate hook. */
338 else if (! NILP (tem1
))
339 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
344 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
345 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
346 Executes BODY just like `progn'.\n\
347 The values of point, mark and the current buffer are restored\n\
348 even in case of abnormal exit (throw or error).\n\
349 The state of activation of the mark is also restored.")
353 register Lisp_Object val
;
354 int count
= specpdl_ptr
- specpdl
;
356 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
359 return unbind_to (count
, val
);
362 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
363 "Return the number of characters in the current buffer.")
367 XSETFASTINT (temp
, Z
- BEG
);
371 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
372 "Return the minimum permissible value of point in the current buffer.\n\
373 This is 1, unless narrowing (a buffer restriction) is in effect.")
377 XSETFASTINT (temp
, BEGV
);
381 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
382 "Return a marker to the minimum permissible value of point in this buffer.\n\
383 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
386 return buildmark (BEGV
);
389 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
390 "Return the maximum permissible value of point in the current buffer.\n\
391 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
392 is in effect, in which case it is less.")
396 XSETFASTINT (temp
, ZV
);
400 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
401 "Return a marker to the maximum permissible value of point in this buffer.\n\
402 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
403 is in effect, in which case it is less.")
406 return buildmark (ZV
);
409 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
410 "Return the character following point, as a number.\n\
411 At the end of the buffer or accessible region, return 0.")
416 XSETFASTINT (temp
, 0);
418 XSETFASTINT (temp
, FETCH_CHAR (point
));
422 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
423 "Return the character preceding point, as a number.\n\
424 At the beginning of the buffer or accessible region, return 0.")
429 XSETFASTINT (temp
, 0);
431 XSETFASTINT (temp
, FETCH_CHAR (point
- 1));
435 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
436 "Return T if point is at the beginning of the buffer.\n\
437 If the buffer is narrowed, this means the beginning of the narrowed part.")
445 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
446 "Return T if point is at the end of the buffer.\n\
447 If the buffer is narrowed, this means the end of the narrowed part.")
455 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
456 "Return T if point is at the beginning of a line.")
459 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
464 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
465 "Return T if point is at the end of a line.\n\
466 `End of a line' includes point being at the end of the buffer.")
469 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
474 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
475 "Return character in current buffer at position POS.\n\
476 POS is an integer or a buffer pointer.\n\
477 If POS is out of range, the value is nil.")
481 register Lisp_Object val
;
484 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
487 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
489 XSETFASTINT (val
, FETCH_CHAR (n
));
493 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
494 "Return the name under which the user logged in, as a string.\n\
495 This is based on the effective uid, not the real uid.\n\
496 Also, if the environment variable LOGNAME or USER is set,\n\
497 that determines the value of this function.\n\n\
498 If optional argument UID is an integer, return the login name of the user\n\
499 with that uid, or nil if there is no such user.")
505 /* Set up the user name info if we didn't do it before.
506 (That can happen if Emacs is dumpable
507 but you decide to run `temacs -l loadup' and not dump. */
508 if (INTEGERP (Vuser_name
))
514 CHECK_NUMBER (uid
, 0);
515 pw
= (struct passwd
*) getpwuid (XINT (uid
));
516 return (pw
? build_string (pw
->pw_name
) : Qnil
);
519 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
521 "Return the name of the user's real uid, as a string.\n\
522 This ignores the environment variables LOGNAME and USER, so it differs from\n\
523 `user-login-name' when running under `su'.")
526 /* Set up the user name info if we didn't do it before.
527 (That can happen if Emacs is dumpable
528 but you decide to run `temacs -l loadup' and not dump. */
529 if (INTEGERP (Vuser_name
))
531 return Vuser_real_name
;
534 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
535 "Return the effective uid of Emacs, as an integer.")
538 return make_number (geteuid ());
541 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
542 "Return the real uid of Emacs, as an integer.")
545 return make_number (getuid ());
548 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
549 "Return the full name of the user logged in, as a string.")
552 return Vuser_full_name
;
555 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
556 "Return the name of the machine you are running on, as a string.")
562 /* For the benefit of callers who don't want to include lisp.h */
566 return (char *) XSTRING (Vsystem_name
)->data
;
569 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
570 "Return the process ID of Emacs, as an integer.")
573 return make_number (getpid ());
576 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
577 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
578 The time is returned as a list of three integers. The first has the\n\
579 most significant 16 bits of the seconds, while the second has the\n\
580 least significant 16 bits. The third integer gives the microsecond\n\
583 The microsecond count is zero on systems that do not provide\n\
584 resolution finer than a second.")
588 Lisp_Object result
[3];
591 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
592 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
593 XSETINT (result
[2], EMACS_USECS (t
));
595 return Flist (3, result
);
600 lisp_time_argument (specified_time
, result
)
601 Lisp_Object specified_time
;
604 if (NILP (specified_time
))
605 return time (result
) != -1;
608 Lisp_Object high
, low
;
609 high
= Fcar (specified_time
);
610 CHECK_NUMBER (high
, 0);
611 low
= Fcdr (specified_time
);
614 CHECK_NUMBER (low
, 0);
615 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
616 return *result
>> 16 == XINT (high
);
620 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 2, 2, 0,
621 "Use FORMAT-STRING to format the time TIME.\n\
622 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from\n\
623 `current-time' and `file-attributes'.\n\
624 FORMAT-STRING may contain %-sequences to substitute parts of the time.\n\
625 %a is replaced by the abbreviated name of the day of week.\n\
626 %A is replaced by the full name of the day of week.\n\
627 %b is replaced by the abbreviated name of the month.\n\
628 %B is replaced by the full name of the month.\n\
629 %c is a synonym for \"%x %X\".\n\
630 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.\n\
631 %d is replaced by the day of month, zero-padded.\n\
632 %D is a synonym for \"%m/%d/%y\".\n\
633 %e is replaced by the day of month, blank-padded.\n\
634 %h is a synonym for \"%b\".\n\
635 %H is replaced by the hour (00-23).\n\
636 %I is replaced by the hour (00-12).\n\
637 %j is replaced by the day of the year (001-366).\n\
638 %k is replaced by the hour (0-23), blank padded.\n\
639 %l is replaced by the hour (1-12), blank padded.\n\
640 %m is replaced by the month (01-12).\n\
641 %M is replaced by the minut (00-59).\n\
642 %n is a synonym for \"\\n\".\n\
643 %p is replaced by AM or PM, as appropriate.\n\
644 %r is a synonym for \"%I:%M:%S %p\".\n\
645 %R is a synonym for \"%H:%M\".\n\
646 %S is replaced by the seconds (00-60).\n\
647 %t is a synonym for \"\\t\".\n\
648 %T is a synonym for \"%H:%M:%S\".\n\
649 %U is replaced by the week of the year (01-52), first day of week is Sunday.\n\
650 %w is replaced by the day of week (0-6), Sunday is day 0.\n\
651 %W is replaced by the week of the year (01-52), first day of week is Monday.\n\
652 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.\n\
653 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.\n\
654 %y is replaced by the year without century (00-99).\n\
655 %Y is replaced by the year with century.\n\
656 %Z is replaced by the time zone abbreviation.\n\
658 The number of options reflects the strftime(3) function.")
659 (format_string
, time
)
660 Lisp_Object format_string
, time
;
665 CHECK_STRING (format_string
, 1);
667 if (! lisp_time_argument (time
, &value
))
668 error ("Invalid time specification");
670 /* This is probably enough. */
671 size
= XSTRING (format_string
)->size
* 6 + 50;
675 char *buf
= (char *) alloca (size
);
676 if (strftime (buf
, size
, XSTRING (format_string
)->data
,
678 return build_string (buf
);
679 /* If buffer was too small, make it bigger. */
684 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
685 "Return the current time, as a human-readable string.\n\
686 Programs can use this function to decode a time,\n\
687 since the number of columns in each field is fixed.\n\
688 The format is `Sun Sep 16 01:03:52 1973'.\n\
689 If an argument is given, it specifies a time to format\n\
690 instead of the current time. The argument should have the form:\n\
693 (HIGH LOW . IGNORED).\n\
694 Thus, you can use times obtained from `current-time'\n\
695 and from `file-attributes'.")
697 Lisp_Object specified_time
;
703 if (! lisp_time_argument (specified_time
, &value
))
705 tem
= (char *) ctime (&value
);
707 strncpy (buf
, tem
, 24);
710 return build_string (buf
);
713 #define TM_YEAR_ORIGIN 1900
715 /* Yield A - B, measured in seconds. */
720 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
721 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
722 /* Some compilers can't handle this as a single return statement. */
724 /* difference in day of year */
725 a
->tm_yday
- b
->tm_yday
726 /* + intervening leap days */
727 + ((ay
>> 2) - (by
>> 2))
729 + ((ay
/100 >> 2) - (by
/100 >> 2))
730 /* + difference in years * 365 */
731 + (long)(ay
-by
) * 365
733 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
734 + (a
->tm_min
- b
->tm_min
))
735 + (a
->tm_sec
- b
->tm_sec
));
738 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
739 "Return the offset and name for the local time zone.\n\
740 This returns a list of the form (OFFSET NAME).\n\
741 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
742 A negative value means west of Greenwich.\n\
743 NAME is a string giving the name of the time zone.\n\
744 If an argument is given, it specifies when the time zone offset is determined\n\
745 instead of using the current time. The argument should have the form:\n\
748 (HIGH LOW . IGNORED).\n\
749 Thus, you can use times obtained from `current-time'\n\
750 and from `file-attributes'.\n\
752 Some operating systems cannot provide all this information to Emacs;\n\
753 in this case, `current-time-zone' returns a list containing nil for\n\
754 the data it can't find.")
756 Lisp_Object specified_time
;
761 if (lisp_time_argument (specified_time
, &value
)
762 && (t
= gmtime (&value
)) != 0)
768 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
769 t
= localtime (&value
);
770 offset
= difftm (t
, &gmt
);
774 s
= (char *)t
->tm_zone
;
775 #else /* not HAVE_TM_ZONE */
777 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
778 s
= tzname
[t
->tm_isdst
];
780 #endif /* not HAVE_TM_ZONE */
783 /* No local time zone name is available; use "+-NNNN" instead. */
784 int am
= (offset
< 0 ? -offset
: offset
) / 60;
785 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
788 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
791 return Fmake_list (2, Qnil
);
803 /* Callers passing one argument to Finsert need not gcpro the
804 argument "array", since the only element of the array will
805 not be used after calling insert or insert_from_string, so
806 we don't care if it gets trashed. */
808 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
809 "Insert the arguments, either strings or characters, at point.\n\
810 Point moves forward so that it ends up after the inserted text.\n\
811 Any other markers at the point of insertion remain before the text.")
814 register Lisp_Object
*args
;
817 register Lisp_Object tem
;
820 for (argnum
= 0; argnum
< nargs
; argnum
++)
829 else if (STRINGP (tem
))
831 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
835 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
843 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
845 "Insert the arguments at point, inheriting properties from adjoining text.\n\
846 Point moves forward so that it ends up after the inserted text.\n\
847 Any other markers at the point of insertion remain before the text.")
850 register Lisp_Object
*args
;
853 register Lisp_Object tem
;
856 for (argnum
= 0; argnum
< nargs
; argnum
++)
863 insert_and_inherit (str
, 1);
865 else if (STRINGP (tem
))
867 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
871 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
879 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
880 "Insert strings or characters at point, relocating markers after the text.\n\
881 Point moves forward so that it ends up after the inserted text.\n\
882 Any other markers at the point of insertion also end up after the text.")
885 register Lisp_Object
*args
;
888 register Lisp_Object tem
;
891 for (argnum
= 0; argnum
< nargs
; argnum
++)
898 insert_before_markers (str
, 1);
900 else if (STRINGP (tem
))
902 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
906 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
914 DEFUN ("insert-before-markers-and-inherit",
915 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
917 "Insert text at point, relocating markers and inheriting properties.\n\
918 Point moves forward so that it ends up after the inserted text.\n\
919 Any other markers at the point of insertion also end up after the text.")
922 register Lisp_Object
*args
;
925 register Lisp_Object tem
;
928 for (argnum
= 0; argnum
< nargs
; argnum
++)
935 insert_before_markers_and_inherit (str
, 1);
937 else if (STRINGP (tem
))
939 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
943 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
951 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
952 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
953 Point and all markers are affected as in the function `insert'.\n\
954 Both arguments are required.\n\
955 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
956 from adjoining text, if those properties are sticky.")
957 (chr
, count
, inherit
)
958 Lisp_Object chr
, count
, inherit
;
960 register unsigned char *string
;
964 CHECK_NUMBER (chr
, 0);
965 CHECK_NUMBER (count
, 1);
970 strlen
= min (n
, 256);
971 string
= (unsigned char *) alloca (strlen
);
972 for (i
= 0; i
< strlen
; i
++)
973 string
[i
] = XFASTINT (chr
);
977 insert_and_inherit (string
, strlen
);
979 insert (string
, strlen
);
988 /* Making strings from buffer contents. */
990 /* Return a Lisp_String containing the text of the current buffer from
991 START to END. If text properties are in use and the current buffer
992 has properties in the range specified, the resulting string will also
995 We don't want to use plain old make_string here, because it calls
996 make_uninit_string, which can cause the buffer arena to be
997 compacted. make_string has no way of knowing that the data has
998 been moved, and thus copies the wrong data into the string. This
999 doesn't effect most of the other users of make_string, so it should
1000 be left as is. But we should use this function when conjuring
1001 buffer substrings. */
1004 make_buffer_string (start
, end
)
1007 Lisp_Object result
, tem
, tem1
;
1009 if (start
< GPT
&& GPT
< end
)
1012 result
= make_uninit_string (end
- start
);
1013 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
1015 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1016 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1018 #ifdef USE_TEXT_PROPERTIES
1019 if (XINT (tem
) != end
|| !NILP (tem1
))
1020 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
1026 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1027 "Return the contents of part of the current buffer as a string.\n\
1028 The two arguments START and END are character positions;\n\
1029 they can be in either order.")
1033 register int beg
, end
;
1035 validate_region (&b
, &e
);
1039 return make_buffer_string (beg
, end
);
1042 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1043 "Return the contents of the current buffer as a string.")
1046 return make_buffer_string (BEGV
, ZV
);
1049 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1051 "Insert before point a substring of the contents of buffer BUFFER.\n\
1052 BUFFER may be a buffer or a buffer name.\n\
1053 Arguments START and END are character numbers specifying the substring.\n\
1054 They default to the beginning and the end of BUFFER.")
1056 Lisp_Object buf
, b
, e
;
1058 register int beg
, end
, temp
, len
, opoint
, start
;
1059 register struct buffer
*bp
;
1062 buffer
= Fget_buffer (buf
);
1065 bp
= XBUFFER (buffer
);
1068 beg
= BUF_BEGV (bp
);
1071 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1078 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1083 temp
= beg
, beg
= end
, end
= temp
;
1085 /* Move the gap or create enough gap in the current buffer. */
1089 if (GAP_SIZE
< end
- beg
)
1090 make_gap (end
- beg
- GAP_SIZE
);
1096 if (!(BUF_BEGV (bp
) <= beg
1098 && end
<= BUF_ZV (bp
)))
1099 args_out_of_range (b
, e
);
1101 /* Now the actual insertion will not do any gap motion,
1102 so it matters not if BUF is the current buffer. */
1103 if (beg
< BUF_GPT (bp
))
1105 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
1106 beg
= min (end
, BUF_GPT (bp
));
1109 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1111 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1112 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1113 opoint
, len
, current_buffer
, 0);
1118 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1120 "Compare two substrings of two buffers; return result as number.\n\
1121 the value is -N if first string is less after N-1 chars,\n\
1122 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1123 Each substring is represented as three arguments: BUFFER, START and END.\n\
1124 That makes six args in all, three for each substring.\n\n\
1125 The value of `case-fold-search' in the current buffer\n\
1126 determines whether case is significant or ignored.")
1127 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1128 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1130 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1131 register struct buffer
*bp1
, *bp2
;
1132 register unsigned char *trt
1133 = (!NILP (current_buffer
->case_fold_search
)
1134 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1136 /* Find the first buffer and its substring. */
1139 bp1
= current_buffer
;
1143 buf1
= Fget_buffer (buffer1
);
1146 bp1
= XBUFFER (buf1
);
1150 begp1
= BUF_BEGV (bp1
);
1153 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1154 begp1
= XINT (start1
);
1157 endp1
= BUF_ZV (bp1
);
1160 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1161 endp1
= XINT (end1
);
1165 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1167 if (!(BUF_BEGV (bp1
) <= begp1
1169 && endp1
<= BUF_ZV (bp1
)))
1170 args_out_of_range (start1
, end1
);
1172 /* Likewise for second substring. */
1175 bp2
= current_buffer
;
1179 buf2
= Fget_buffer (buffer2
);
1182 bp2
= XBUFFER (buffer2
);
1186 begp2
= BUF_BEGV (bp2
);
1189 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1190 begp2
= XINT (start2
);
1193 endp2
= BUF_ZV (bp2
);
1196 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1197 endp2
= XINT (end2
);
1201 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1203 if (!(BUF_BEGV (bp2
) <= begp2
1205 && endp2
<= BUF_ZV (bp2
)))
1206 args_out_of_range (start2
, end2
);
1208 len1
= endp1
- begp1
;
1209 len2
= endp2
- begp2
;
1214 for (i
= 0; i
< length
; i
++)
1216 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1217 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1224 return make_number (- 1 - i
);
1226 return make_number (i
+ 1);
1229 /* The strings match as far as they go.
1230 If one is shorter, that one is less. */
1232 return make_number (length
+ 1);
1233 else if (length
< len2
)
1234 return make_number (- length
- 1);
1236 /* Same length too => they are equal. */
1237 return make_number (0);
1240 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1241 Ssubst_char_in_region
, 4, 5, 0,
1242 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1243 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1244 and don't mark the buffer as really changed.")
1245 (start
, end
, fromchar
, tochar
, noundo
)
1246 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1248 register int pos
, stop
, look
;
1251 validate_region (&start
, &end
);
1252 CHECK_NUMBER (fromchar
, 2);
1253 CHECK_NUMBER (tochar
, 3);
1257 look
= XINT (fromchar
);
1261 if (FETCH_CHAR (pos
) == look
)
1265 modify_region (current_buffer
, XINT (start
), stop
);
1267 if (! NILP (noundo
))
1269 if (MODIFF
- 1 == current_buffer
->save_modified
)
1270 current_buffer
->save_modified
++;
1271 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1272 current_buffer
->auto_save_modified
++;
1279 record_change (pos
, 1);
1280 FETCH_CHAR (pos
) = XINT (tochar
);
1286 signal_after_change (XINT (start
),
1287 stop
- XINT (start
), stop
- XINT (start
));
1292 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1293 "From START to END, translate characters according to TABLE.\n\
1294 TABLE is a string; the Nth character in it is the mapping\n\
1295 for the character with code N. Returns the number of characters changed.")
1299 register Lisp_Object table
;
1301 register int pos
, stop
; /* Limits of the region. */
1302 register unsigned char *tt
; /* Trans table. */
1303 register int oc
; /* Old character. */
1304 register int nc
; /* New character. */
1305 int cnt
; /* Number of changes made. */
1306 Lisp_Object z
; /* Return. */
1307 int size
; /* Size of translate table. */
1309 validate_region (&start
, &end
);
1310 CHECK_STRING (table
, 2);
1312 size
= XSTRING (table
)->size
;
1313 tt
= XSTRING (table
)->data
;
1317 modify_region (current_buffer
, pos
, stop
);
1320 for (; pos
< stop
; ++pos
)
1322 oc
= FETCH_CHAR (pos
);
1328 record_change (pos
, 1);
1329 FETCH_CHAR (pos
) = nc
;
1330 signal_after_change (pos
, 1, 1);
1336 XSETFASTINT (z
, cnt
);
1340 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1341 "Delete the text between point and mark.\n\
1342 When called from a program, expects two arguments,\n\
1343 positions (integers or markers) specifying the stretch to be deleted.")
1347 validate_region (&b
, &e
);
1348 del_range (XINT (b
), XINT (e
));
1352 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1353 "Remove restrictions (narrowing) from current buffer.\n\
1354 This allows the buffer's full text to be seen and edited.")
1358 SET_BUF_ZV (current_buffer
, Z
);
1360 /* Changing the buffer bounds invalidates any recorded current column. */
1361 invalidate_current_column ();
1365 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1366 "Restrict editing in this buffer to the current region.\n\
1367 The rest of the text becomes temporarily invisible and untouchable\n\
1368 but is not deleted; if you save the buffer in a file, the invisible\n\
1369 text is included in the file. \\[widen] makes all visible again.\n\
1370 See also `save-restriction'.\n\
1372 When calling from a program, pass two arguments; positions (integers\n\
1373 or markers) bounding the text that should remain visible.")
1375 register Lisp_Object b
, e
;
1377 register EMACS_INT i
;
1379 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1380 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1382 if (XINT (b
) > XINT (e
))
1389 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1390 args_out_of_range (b
, e
);
1392 BEGV
= XFASTINT (b
);
1393 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1394 if (point
< XFASTINT (b
))
1395 SET_PT (XFASTINT (b
));
1396 if (point
> XFASTINT (e
))
1397 SET_PT (XFASTINT (e
));
1399 /* Changing the buffer bounds invalidates any recorded current column. */
1400 invalidate_current_column ();
1405 save_restriction_save ()
1407 register Lisp_Object bottom
, top
;
1408 /* Note: I tried using markers here, but it does not win
1409 because insertion at the end of the saved region
1410 does not advance mh and is considered "outside" the saved region. */
1411 XSETFASTINT (bottom
, BEGV
- BEG
);
1412 XSETFASTINT (top
, Z
- ZV
);
1414 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1418 save_restriction_restore (data
)
1421 register struct buffer
*buf
;
1422 register int newhead
, newtail
;
1423 register Lisp_Object tem
;
1425 buf
= XBUFFER (XCONS (data
)->car
);
1427 data
= XCONS (data
)->cdr
;
1429 tem
= XCONS (data
)->car
;
1430 newhead
= XINT (tem
);
1431 tem
= XCONS (data
)->cdr
;
1432 newtail
= XINT (tem
);
1433 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1438 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1439 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1442 /* If point is outside the new visible range, move it inside. */
1444 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1449 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1450 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1451 The buffer's restrictions make parts of the beginning and end invisible.\n\
1452 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1453 This special form, `save-restriction', saves the current buffer's restrictions\n\
1454 when it is entered, and restores them when it is exited.\n\
1455 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1456 The old restrictions settings are restored\n\
1457 even in case of abnormal exit (throw or error).\n\
1459 The value returned is the value of the last form in BODY.\n\
1461 `save-restriction' can get confused if, within the BODY, you widen\n\
1462 and then make changes outside the area within the saved restrictions.\n\
1464 Note: if you are using both `save-excursion' and `save-restriction',\n\
1465 use `save-excursion' outermost:\n\
1466 (save-excursion (save-restriction ...))")
1470 register Lisp_Object val
;
1471 int count
= specpdl_ptr
- specpdl
;
1473 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1474 val
= Fprogn (body
);
1475 return unbind_to (count
, val
);
1478 /* Buffer for the most recent text displayed by Fmessage. */
1479 static char *message_text
;
1481 /* Allocated length of that buffer. */
1482 static int message_length
;
1484 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1485 "Print a one-line message at the bottom of the screen.\n\
1486 The first argument is a control string.\n\
1487 It may contain %s or %d or %c to print successive following arguments.\n\
1488 %s means print an argument as a string, %d means print as number in decimal,\n\
1489 %c means print a number as a single character.\n\
1490 The argument used by %s must be a string or a symbol;\n\
1491 the argument used by %d or %c must be a number.\n\
1492 If the first argument is nil, clear any existing message; let the\n\
1493 minibuffer contents show.")
1505 register Lisp_Object val
;
1506 val
= Fformat (nargs
, args
);
1507 /* Copy the data so that it won't move when we GC. */
1510 message_text
= (char *)xmalloc (80);
1511 message_length
= 80;
1513 if (XSTRING (val
)->size
> message_length
)
1515 message_length
= XSTRING (val
)->size
;
1516 message_text
= (char *)xrealloc (message_text
, message_length
);
1518 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1519 message2 (message_text
, XSTRING (val
)->size
);
1524 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
1525 "Display a message, in a dialog box if possible.\n\
1526 If a dialog box is not available, use the echo area.\n\
1527 The first argument is a control string.\n\
1528 It may contain %s or %d or %c to print successive following arguments.\n\
1529 %s means print an argument as a string, %d means print as number in decimal,\n\
1530 %c means print a number as a single character.\n\
1531 The argument used by %s must be a string or a symbol;\n\
1532 the argument used by %d or %c must be a number.\n\
1533 If the first argument is nil, clear any existing message; let the\n\
1534 minibuffer contents show.")
1546 register Lisp_Object val
;
1547 val
= Fformat (nargs
, args
);
1550 Lisp_Object pane
, menu
, obj
;
1551 struct gcpro gcpro1
;
1552 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
1554 menu
= Fcons (val
, pane
);
1555 obj
= Fx_popup_dialog (Qt
, menu
);
1560 /* Copy the data so that it won't move when we GC. */
1563 message_text
= (char *)xmalloc (80);
1564 message_length
= 80;
1566 if (XSTRING (val
)->size
> message_length
)
1568 message_length
= XSTRING (val
)->size
;
1569 message_text
= (char *)xrealloc (message_text
, message_length
);
1571 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1572 message2 (message_text
, XSTRING (val
)->size
);
1578 extern Lisp_Object last_nonmenu_event
;
1580 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
1581 "Display a message in a dialog box or in the echo area.\n\
1582 If this command was invoked with the mouse, use a dialog box.\n\
1583 Otherwise, use the echo area.\n\
1585 The first argument is a control string.\n\
1586 It may contain %s or %d or %c to print successive following arguments.\n\
1587 %s means print an argument as a string, %d means print as number in decimal,\n\
1588 %c means print a number as a single character.\n\
1589 The argument used by %s must be a string or a symbol;\n\
1590 the argument used by %d or %c must be a number.\n\
1591 If the first argument is nil, clear any existing message; let the\n\
1592 minibuffer contents show.")
1598 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1599 return Fmessage_box (nargs
, args
);
1601 return Fmessage (nargs
, args
);
1604 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1605 "Format a string out of a control-string and arguments.\n\
1606 The first argument is a control string.\n\
1607 The other arguments are substituted into it to make the result, a string.\n\
1608 It may contain %-sequences meaning to substitute the next argument.\n\
1609 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1610 %d means print as number in decimal (%o octal, %x hex).\n\
1611 %c means print a number as a single character.\n\
1612 %S means print any object as an s-expression (using prin1).\n\
1613 The argument used for %d, %o, %x or %c must be a number.\n\
1614 Use %% to put a single % into the output.")
1617 register Lisp_Object
*args
;
1619 register int n
; /* The number of the next arg to substitute */
1620 register int total
= 5; /* An estimate of the final length */
1622 register unsigned char *format
, *end
;
1624 extern char *index ();
1625 /* It should not be necessary to GCPRO ARGS, because
1626 the caller in the interpreter should take care of that. */
1628 CHECK_STRING (args
[0], 0);
1629 format
= XSTRING (args
[0])->data
;
1630 end
= format
+ XSTRING (args
[0])->size
;
1633 while (format
!= end
)
1634 if (*format
++ == '%')
1638 /* Process a numeric arg and skip it. */
1639 minlen
= atoi (format
);
1644 while ((*format
>= '0' && *format
<= '9')
1645 || *format
== '-' || *format
== ' ' || *format
== '.')
1650 else if (++n
>= nargs
)
1651 error ("not enough arguments for format string");
1652 else if (*format
== 'S')
1654 /* For `S', prin1 the argument and then treat like a string. */
1655 register Lisp_Object tem
;
1656 tem
= Fprin1_to_string (args
[n
], Qnil
);
1660 else if (SYMBOLP (args
[n
]))
1662 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
1665 else if (STRINGP (args
[n
]))
1668 if (*format
!= 's' && *format
!= 'S')
1669 error ("format specifier doesn't match argument type");
1670 total
+= XSTRING (args
[n
])->size
;
1672 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1673 else if (INTEGERP (args
[n
]) && *format
!= 's')
1675 #ifdef LISP_FLOAT_TYPE
1676 /* The following loop assumes the Lisp type indicates
1677 the proper way to pass the argument.
1678 So make sure we have a flonum if the argument should
1680 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1681 args
[n
] = Ffloat (args
[n
]);
1685 #ifdef LISP_FLOAT_TYPE
1686 else if (FLOATP (args
[n
]) && *format
!= 's')
1688 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1689 args
[n
] = Ftruncate (args
[n
]);
1695 /* Anything but a string, convert to a string using princ. */
1696 register Lisp_Object tem
;
1697 tem
= Fprin1_to_string (args
[n
], Qt
);
1704 register int nstrings
= n
+ 1;
1706 /* Allocate twice as many strings as we have %-escapes; floats occupy
1707 two slots, and we're not sure how many of those we have. */
1708 register unsigned char **strings
1709 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1713 for (n
= 0; n
< nstrings
; n
++)
1716 strings
[i
++] = (unsigned char *) "";
1717 else if (INTEGERP (args
[n
]))
1718 /* We checked above that the corresponding format effector
1719 isn't %s, which would cause MPV. */
1720 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1721 #ifdef LISP_FLOAT_TYPE
1722 else if (FLOATP (args
[n
]))
1724 union { double d
; int half
[2]; } u
;
1726 u
.d
= XFLOAT (args
[n
])->data
;
1727 strings
[i
++] = (unsigned char *) u
.half
[0];
1728 strings
[i
++] = (unsigned char *) u
.half
[1];
1732 strings
[i
++] = XSTRING (args
[n
])->data
;
1735 /* Format it in bigger and bigger buf's until it all fits. */
1738 buf
= (char *) alloca (total
+ 1);
1741 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1742 if (buf
[total
- 1] == 0)
1750 return make_string (buf
, length
);
1756 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1757 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
1771 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1773 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1775 return build_string (buf
);
1778 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1779 "Return t if two characters match, optionally ignoring case.\n\
1780 Both arguments must be characters (i.e. integers).\n\
1781 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1783 register Lisp_Object c1
, c2
;
1785 unsigned char *downcase
= DOWNCASE_TABLE
;
1786 CHECK_NUMBER (c1
, 0);
1787 CHECK_NUMBER (c2
, 1);
1789 if (!NILP (current_buffer
->case_fold_search
)
1790 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1791 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1792 : XINT (c1
) == XINT (c2
))
1797 /* Transpose the markers in two regions of the current buffer, and
1798 adjust the ones between them if necessary (i.e.: if the regions
1801 Traverses the entire marker list of the buffer to do so, adding an
1802 appropriate amount to some, subtracting from some, and leaving the
1803 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1805 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1808 transpose_markers (start1
, end1
, start2
, end2
)
1809 register int start1
, end1
, start2
, end2
;
1811 register int amt1
, amt2
, diff
, mpos
;
1812 register Lisp_Object marker
;
1814 /* Update point as if it were a marker. */
1818 TEMP_SET_PT (PT
+ (end2
- end1
));
1819 else if (PT
< start2
)
1820 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1822 TEMP_SET_PT (PT
- (start2
- start1
));
1824 /* We used to adjust the endpoints here to account for the gap, but that
1825 isn't good enough. Even if we assume the caller has tried to move the
1826 gap out of our way, it might still be at start1 exactly, for example;
1827 and that places it `inside' the interval, for our purposes. The amount
1828 of adjustment is nontrivial if there's a `denormalized' marker whose
1829 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1830 the dirty work to Fmarker_position, below. */
1832 /* The difference between the region's lengths */
1833 diff
= (end2
- start2
) - (end1
- start1
);
1835 /* For shifting each marker in a region by the length of the other
1836 * region plus the distance between the regions.
1838 amt1
= (end2
- start2
) + (start2
- end1
);
1839 amt2
= (end1
- start1
) + (start2
- end1
);
1841 for (marker
= current_buffer
->markers
; !NILP (marker
);
1842 marker
= XMARKER (marker
)->chain
)
1844 mpos
= Fmarker_position (marker
);
1845 if (mpos
>= start1
&& mpos
< end2
)
1849 else if (mpos
< start2
)
1853 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1854 XMARKER (marker
)->bufpos
= mpos
;
1859 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1860 "Transpose region START1 to END1 with START2 to END2.\n\
1861 The regions may not be overlapping, because the size of the buffer is\n\
1862 never changed in a transposition.\n\
1864 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1865 any markers that happen to be located in the regions.\n\
1867 Transposing beyond buffer boundaries is an error.")
1868 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1869 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1871 register int start1
, end1
, start2
, end2
,
1872 gap
, len1
, len_mid
, len2
;
1873 unsigned char *start1_addr
, *start2_addr
, *temp
;
1875 #ifdef USE_TEXT_PROPERTIES
1876 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1877 cur_intv
= current_buffer
->intervals
;
1878 #endif /* USE_TEXT_PROPERTIES */
1880 validate_region (&startr1
, &endr1
);
1881 validate_region (&startr2
, &endr2
);
1883 start1
= XFASTINT (startr1
);
1884 end1
= XFASTINT (endr1
);
1885 start2
= XFASTINT (startr2
);
1886 end2
= XFASTINT (endr2
);
1889 /* Swap the regions if they're reversed. */
1892 register int glumph
= start1
;
1900 len1
= end1
- start1
;
1901 len2
= end2
- start2
;
1904 error ("transposed regions not properly ordered");
1905 else if (start1
== end1
|| start2
== end2
)
1906 error ("transposed region may not be of length 0");
1908 /* The possibilities are:
1909 1. Adjacent (contiguous) regions, or separate but equal regions
1910 (no, really equal, in this case!), or
1911 2. Separate regions of unequal size.
1913 The worst case is usually No. 2. It means that (aside from
1914 potential need for getting the gap out of the way), there also
1915 needs to be a shifting of the text between the two regions. So
1916 if they are spread far apart, we are that much slower... sigh. */
1918 /* It must be pointed out that the really studly thing to do would
1919 be not to move the gap at all, but to leave it in place and work
1920 around it if necessary. This would be extremely efficient,
1921 especially considering that people are likely to do
1922 transpositions near where they are working interactively, which
1923 is exactly where the gap would be found. However, such code
1924 would be much harder to write and to read. So, if you are
1925 reading this comment and are feeling squirrely, by all means have
1926 a go! I just didn't feel like doing it, so I will simply move
1927 the gap the minimum distance to get it out of the way, and then
1928 deal with an unbroken array. */
1930 /* Make sure the gap won't interfere, by moving it out of the text
1931 we will operate on. */
1932 if (start1
< gap
&& gap
< end2
)
1934 if (gap
- start1
< end2
- gap
)
1940 /* Hmmm... how about checking to see if the gap is large
1941 enough to use as the temporary storage? That would avoid an
1942 allocation... interesting. Later, don't fool with it now. */
1944 /* Working without memmove, for portability (sigh), so must be
1945 careful of overlapping subsections of the array... */
1947 if (end1
== start2
) /* adjacent regions */
1949 modify_region (current_buffer
, start1
, end2
);
1950 record_change (start1
, len1
+ len2
);
1952 #ifdef USE_TEXT_PROPERTIES
1953 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1954 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1955 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1956 #endif /* USE_TEXT_PROPERTIES */
1958 /* First region smaller than second. */
1961 /* We use alloca only if it is small,
1962 because we want to avoid stack overflow. */
1964 temp
= (unsigned char *) xmalloc (len2
);
1966 temp
= (unsigned char *) alloca (len2
);
1968 /* Don't precompute these addresses. We have to compute them
1969 at the last minute, because the relocating allocator might
1970 have moved the buffer around during the xmalloc. */
1971 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1972 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1974 bcopy (start2_addr
, temp
, len2
);
1975 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
1976 bcopy (temp
, start1_addr
, len2
);
1981 /* First region not smaller than second. */
1984 temp
= (unsigned char *) xmalloc (len1
);
1986 temp
= (unsigned char *) alloca (len1
);
1987 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1988 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
1989 bcopy (start1_addr
, temp
, len1
);
1990 bcopy (start2_addr
, start1_addr
, len2
);
1991 bcopy (temp
, start1_addr
+ len2
, len1
);
1995 #ifdef USE_TEXT_PROPERTIES
1996 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
1997 len1
, current_buffer
, 0);
1998 graft_intervals_into_buffer (tmp_interval2
, start1
,
1999 len2
, current_buffer
, 0);
2000 #endif /* USE_TEXT_PROPERTIES */
2002 /* Non-adjacent regions, because end1 != start2, bleagh... */
2006 /* Regions are same size, though, how nice. */
2008 modify_region (current_buffer
, start1
, end1
);
2009 modify_region (current_buffer
, start2
, end2
);
2010 record_change (start1
, len1
);
2011 record_change (start2
, len2
);
2012 #ifdef USE_TEXT_PROPERTIES
2013 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2014 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2015 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
2016 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
2017 #endif /* USE_TEXT_PROPERTIES */
2020 temp
= (unsigned char *) xmalloc (len1
);
2022 temp
= (unsigned char *) alloca (len1
);
2023 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2024 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2025 bcopy (start1_addr
, temp
, len1
);
2026 bcopy (start2_addr
, start1_addr
, len2
);
2027 bcopy (temp
, start2_addr
, len1
);
2030 #ifdef USE_TEXT_PROPERTIES
2031 graft_intervals_into_buffer (tmp_interval1
, start2
,
2032 len1
, current_buffer
, 0);
2033 graft_intervals_into_buffer (tmp_interval2
, start1
,
2034 len2
, current_buffer
, 0);
2035 #endif /* USE_TEXT_PROPERTIES */
2038 else if (len1
< len2
) /* Second region larger than first */
2039 /* Non-adjacent & unequal size, area between must also be shifted. */
2041 len_mid
= start2
- end1
;
2042 modify_region (current_buffer
, start1
, end2
);
2043 record_change (start1
, (end2
- start1
));
2044 #ifdef USE_TEXT_PROPERTIES
2045 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2046 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2047 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2048 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2049 #endif /* USE_TEXT_PROPERTIES */
2051 /* holds region 2 */
2053 temp
= (unsigned char *) xmalloc (len2
);
2055 temp
= (unsigned char *) alloca (len2
);
2056 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2057 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2058 bcopy (start2_addr
, temp
, len2
);
2059 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
2060 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2061 bcopy (temp
, start1_addr
, len2
);
2064 #ifdef USE_TEXT_PROPERTIES
2065 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2066 len1
, current_buffer
, 0);
2067 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2068 len_mid
, current_buffer
, 0);
2069 graft_intervals_into_buffer (tmp_interval2
, start1
,
2070 len2
, current_buffer
, 0);
2071 #endif /* USE_TEXT_PROPERTIES */
2074 /* Second region smaller than first. */
2076 len_mid
= start2
- end1
;
2077 record_change (start1
, (end2
- start1
));
2078 modify_region (current_buffer
, start1
, end2
);
2080 #ifdef USE_TEXT_PROPERTIES
2081 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2082 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2083 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2084 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2085 #endif /* USE_TEXT_PROPERTIES */
2087 /* holds region 1 */
2089 temp
= (unsigned char *) xmalloc (len1
);
2091 temp
= (unsigned char *) alloca (len1
);
2092 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2093 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2094 bcopy (start1_addr
, temp
, len1
);
2095 bcopy (start2_addr
, start1_addr
, len2
);
2096 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2097 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
2100 #ifdef USE_TEXT_PROPERTIES
2101 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2102 len1
, current_buffer
, 0);
2103 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2104 len_mid
, current_buffer
, 0);
2105 graft_intervals_into_buffer (tmp_interval2
, start1
,
2106 len2
, current_buffer
, 0);
2107 #endif /* USE_TEXT_PROPERTIES */
2111 /* todo: this will be slow, because for every transposition, we
2112 traverse the whole friggin marker list. Possible solutions:
2113 somehow get a list of *all* the markers across multiple
2114 transpositions and do it all in one swell phoop. Or maybe modify
2115 Emacs' marker code to keep an ordered list or tree. This might
2116 be nicer, and more beneficial in the long run, but would be a
2117 bunch of work. Plus the way they're arranged now is nice. */
2118 if (NILP (leave_markers
))
2120 transpose_markers (start1
, end1
, start2
, end2
);
2121 fix_overlays_in_range (start1
, end2
);
2131 DEFVAR_LISP ("system-name", &Vsystem_name
,
2132 "The name of the machine Emacs is running on.");
2134 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2135 "The full name of the user logged in.");
2137 DEFVAR_LISP ("user-name", &Vuser_name
,
2138 "The user's name, taken from environment variables if possible.");
2140 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
2141 "The user's name, based upon the real uid only.");
2143 defsubr (&Schar_equal
);
2144 defsubr (&Sgoto_char
);
2145 defsubr (&Sstring_to_char
);
2146 defsubr (&Schar_to_string
);
2147 defsubr (&Sbuffer_substring
);
2148 defsubr (&Sbuffer_string
);
2150 defsubr (&Spoint_marker
);
2151 defsubr (&Smark_marker
);
2153 defsubr (&Sregion_beginning
);
2154 defsubr (&Sregion_end
);
2155 /* defsubr (&Smark); */
2156 /* defsubr (&Sset_mark); */
2157 defsubr (&Ssave_excursion
);
2159 defsubr (&Sbufsize
);
2160 defsubr (&Spoint_max
);
2161 defsubr (&Spoint_min
);
2162 defsubr (&Spoint_min_marker
);
2163 defsubr (&Spoint_max_marker
);
2169 defsubr (&Sfollowing_char
);
2170 defsubr (&Sprevious_char
);
2171 defsubr (&Schar_after
);
2173 defsubr (&Sinsert_before_markers
);
2174 defsubr (&Sinsert_and_inherit
);
2175 defsubr (&Sinsert_and_inherit_before_markers
);
2176 defsubr (&Sinsert_char
);
2178 defsubr (&Suser_login_name
);
2179 defsubr (&Suser_real_login_name
);
2180 defsubr (&Suser_uid
);
2181 defsubr (&Suser_real_uid
);
2182 defsubr (&Suser_full_name
);
2183 defsubr (&Semacs_pid
);
2184 defsubr (&Scurrent_time
);
2185 defsubr (&Sformat_time_string
);
2186 defsubr (&Scurrent_time_string
);
2187 defsubr (&Scurrent_time_zone
);
2188 defsubr (&Ssystem_name
);
2189 defsubr (&Smessage
);
2190 defsubr (&Smessage_box
);
2191 defsubr (&Smessage_or_box
);
2194 defsubr (&Sinsert_buffer_substring
);
2195 defsubr (&Scompare_buffer_substrings
);
2196 defsubr (&Ssubst_char_in_region
);
2197 defsubr (&Stranslate_region
);
2198 defsubr (&Sdelete_region
);
2200 defsubr (&Snarrow_to_region
);
2201 defsubr (&Ssave_restriction
);
2202 defsubr (&Stranspose_regions
);