1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993 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 USER or LOGNAME. */
52 register unsigned char *p
, *q
, *r
;
53 struct passwd
*pw
; /* password entry for the current user */
54 extern char *index ();
57 /* Set up system_name even when dumping. */
59 Vsystem_name
= build_string (get_system_name ());
60 p
= XSTRING (Vsystem_name
)->data
;
63 if (*p
== ' ' || *p
== '\t')
69 /* Don't bother with this on initial start when just dumping out */
72 #endif /* not CANNOT_DUMP */
74 pw
= (struct passwd
*) getpwuid (getuid ());
75 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
77 /* Get the effective user name, by consulting environment variables,
78 or the effective uid if those are unset. */
79 user_name
= (char *) getenv ("USER");
81 user_name
= (char *) getenv ("LOGNAME");
84 pw
= (struct passwd
*) getpwuid (geteuid ());
85 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
87 Vuser_name
= build_string (user_name
);
89 /* If the user name claimed in the environment vars differs from
90 the real uid, use the claimed name to find the full name. */
91 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
93 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
95 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
96 q
= (unsigned char *) index (p
, ',');
97 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
99 #ifdef AMPERSAND_FULL_NAME
100 p
= XSTRING (Vuser_full_name
)->data
;
101 q
= (char *) index (p
, '&');
102 /* Substitute the login name for the &, upcasing the first character. */
105 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
108 strcat (r
, XSTRING (Vuser_name
)->data
);
109 r
[q
- p
] = UPCASE (r
[q
- p
]);
111 Vuser_full_name
= build_string (r
);
113 #endif /* AMPERSAND_FULL_NAME */
116 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
117 "Convert arg CHAR to a one-character string containing that character.")
125 return make_string (&c
, 1);
128 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
129 "Convert arg STRING to a character, the first character of that string.")
131 register Lisp_Object str
;
133 register Lisp_Object val
;
134 register struct Lisp_String
*p
;
135 CHECK_STRING (str
, 0);
139 XFASTINT (val
) = ((unsigned char *) p
->data
)[0];
149 register Lisp_Object mark
;
150 mark
= Fmake_marker ();
151 Fset_marker (mark
, make_number (val
), Qnil
);
155 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
156 "Return value of point, as an integer.\n\
157 Beginning of buffer is position (point-min)")
161 XFASTINT (temp
) = point
;
165 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
166 "Return value of point, as a marker object.")
169 return buildmark (point
);
173 clip_to_bounds (lower
, num
, upper
)
174 int lower
, num
, upper
;
178 else if (num
> upper
)
184 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
185 "Set point to POSITION, a number or marker.\n\
186 Beginning of buffer is position (point-min), end is (point-max).")
188 register Lisp_Object n
;
190 CHECK_NUMBER_COERCE_MARKER (n
, 0);
192 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
197 region_limit (beginningp
)
200 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
201 register Lisp_Object m
;
202 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
203 && NILP (current_buffer
->mark_active
))
204 Fsignal (Qmark_inactive
, Qnil
);
205 m
= Fmarker_position (current_buffer
->mark
);
206 if (NILP (m
)) error ("There is no region now");
207 if ((point
< XFASTINT (m
)) == beginningp
)
208 return (make_number (point
));
213 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
214 "Return position of beginning of region, as an integer.")
217 return (region_limit (1));
220 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
221 "Return position of end of region, as an integer.")
224 return (region_limit (0));
227 #if 0 /* now in lisp code */
228 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
229 "Return this buffer's mark value as integer, or nil if no mark.\n\
230 If you are using this in an editing command, you are most likely making\n\
231 a mistake; see the documentation of `set-mark'.")
234 return Fmarker_position (current_buffer
->mark
);
236 #endif /* commented out code */
238 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
239 "Return this buffer's mark, as a marker object.\n\
240 Watch out! Moving this marker changes the mark position.\n\
241 If you set the marker not to point anywhere, the buffer will have no mark.")
244 return current_buffer
->mark
;
247 #if 0 /* this is now in lisp code */
248 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
249 "Set this buffer's mark to POS. Don't use this function!\n\
250 That is to say, don't use this function unless you want\n\
251 the user to see that the mark has moved, and you want the previous\n\
252 mark position to be lost.\n\
254 Normally, when a new mark is set, the old one should go on the stack.\n\
255 This is why most applications should use push-mark, not set-mark.\n\
257 Novice programmers often try to use the mark for the wrong purposes.\n\
258 The mark saves a location for the user's convenience.\n\
259 Most editing commands should not alter the mark.\n\
260 To remember a location for internal use in the Lisp program,\n\
261 store it in a Lisp variable. Example:\n\
263 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
269 current_buffer
->mark
= Qnil
;
272 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
274 if (NILP (current_buffer
->mark
))
275 current_buffer
->mark
= Fmake_marker ();
277 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
280 #endif /* commented-out code */
283 save_excursion_save ()
285 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
288 return Fcons (Fpoint_marker (),
289 Fcons (Fcopy_marker (current_buffer
->mark
),
290 Fcons (visible
? Qt
: Qnil
,
291 current_buffer
->mark_active
)));
295 save_excursion_restore (info
)
296 register Lisp_Object info
;
298 register Lisp_Object tem
, tem1
;
300 tem
= Fmarker_buffer (Fcar (info
));
301 /* If buffer being returned to is now deleted, avoid error */
302 /* Otherwise could get error here while unwinding to top level
304 /* In that case, Fmarker_buffer returns nil now. */
310 unchain_marker (tem
);
311 tem
= Fcar (Fcdr (info
));
312 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
313 unchain_marker (tem
);
314 tem
= Fcdr (Fcdr (info
));
315 #if 0 /* We used to make the current buffer visible in the selected window
316 if that was true previously. That avoids some anomalies.
317 But it creates others, and it wasn't documented, and it is simpler
318 and cleaner never to alter the window/buffer connections. */
321 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
322 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
325 tem1
= current_buffer
->mark_active
;
326 current_buffer
->mark_active
= Fcdr (tem
);
327 if (! NILP (current_buffer
->mark_active
))
328 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
329 else if (! NILP (tem1
))
330 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
334 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
335 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
336 Executes BODY just like `progn'.\n\
337 The values of point, mark and the current buffer are restored\n\
338 even in case of abnormal exit (throw or error).\n\
339 The state of activation of the mark is also restored.")
343 register Lisp_Object val
;
344 int count
= specpdl_ptr
- specpdl
;
346 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
349 return unbind_to (count
, val
);
352 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
353 "Return the number of characters in the current buffer.")
357 XFASTINT (temp
) = Z
- BEG
;
361 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
362 "Return the minimum permissible value of point in the current buffer.\n\
363 This is 1, unless narrowing (a buffer restriction) is in effect.")
367 XFASTINT (temp
) = BEGV
;
371 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
372 "Return a marker to the minimum permissible value of point in this buffer.\n\
373 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
376 return buildmark (BEGV
);
379 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
380 "Return the maximum permissible value of point in the current buffer.\n\
381 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
382 is in effect, in which case it is less.")
386 XFASTINT (temp
) = ZV
;
390 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
391 "Return a marker to the maximum permissible value of point in this buffer.\n\
392 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
393 is in effect, in which case it is less.")
396 return buildmark (ZV
);
399 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
400 "Return the character following point, as a number.\n\
401 At the end of the buffer or accessible region, return 0.")
408 XFASTINT (temp
) = FETCH_CHAR (point
);
412 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
413 "Return the character preceding point, as a number.\n\
414 At the beginning of the buffer or accessible region, return 0.")
421 XFASTINT (temp
) = FETCH_CHAR (point
- 1);
425 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
426 "Return T if point is at the beginning of the buffer.\n\
427 If the buffer is narrowed, this means the beginning of the narrowed part.")
435 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
436 "Return T if point is at the end of the buffer.\n\
437 If the buffer is narrowed, this means the end of the narrowed part.")
445 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
446 "Return T if point is at the beginning of a line.")
449 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
454 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
455 "Return T if point is at the end of a line.\n\
456 `End of a line' includes point being at the end of the buffer.")
459 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
464 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
465 "Return character in current buffer at position POS.\n\
466 POS is an integer or a buffer pointer.\n\
467 If POS is out of range, the value is nil.")
471 register Lisp_Object val
;
474 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
477 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
479 XFASTINT (val
) = FETCH_CHAR (n
);
483 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 0, 0,
484 "Return the name under which the user logged in, as a string.\n\
485 This is based on the effective uid, not the real uid.\n\
486 Also, if the environment variable USER or LOGNAME is set,\n\
487 that determines the value of this function.")
493 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
495 "Return the name of the user's real uid, as a string.\n\
496 Differs from `user-login-name' when running under `su'.")
499 return Vuser_real_name
;
502 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
503 "Return the effective uid of Emacs, as an integer.")
506 return make_number (geteuid ());
509 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
510 "Return the real uid of Emacs, as an integer.")
513 return make_number (getuid ());
516 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
517 "Return the full name of the user logged in, as a string.")
520 return Vuser_full_name
;
523 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
524 "Return the name of the machine you are running on, as a string.")
530 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
531 "Return the process ID of Emacs, as an integer.")
534 return make_number (getpid ());
537 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
538 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
539 The time is returned as a list of three integers. The first has the\n\
540 most significant 16 bits of the seconds, while the second has the\n\
541 least significant 16 bits. The third integer gives the microsecond\n\
544 The microsecond count is zero on systems that do not provide\n\
545 resolution finer than a second.")
549 Lisp_Object result
[3];
552 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
553 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
554 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
556 return Flist (3, result
);
561 lisp_time_argument (specified_time
, result
)
562 Lisp_Object specified_time
;
565 if (NILP (specified_time
))
566 return time (result
) != -1;
569 Lisp_Object high
, low
;
570 high
= Fcar (specified_time
);
571 CHECK_NUMBER (high
, 0);
572 low
= Fcdr (specified_time
);
573 if (XTYPE (low
) == Lisp_Cons
)
575 CHECK_NUMBER (low
, 0);
576 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
577 return *result
>> 16 == XINT (high
);
581 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
582 "Return the current time, as a human-readable string.\n\
583 Programs can use this function to decode a time,\n\
584 since the number of columns in each field is fixed.\n\
585 The format is `Sun Sep 16 01:03:52 1973'.\n\
586 If an argument is given, it specifies a time to format\n\
587 instead of the current time. The argument should have the form:\n\
590 (HIGH LOW . IGNORED).\n\
591 Thus, you can use times obtained from `current-time'\n\
592 and from `file-attributes'.")
594 Lisp_Object specified_time
;
600 if (! lisp_time_argument (specified_time
, &value
))
602 tem
= (char *) ctime (&value
);
604 strncpy (buf
, tem
, 24);
607 return build_string (buf
);
610 #define TM_YEAR_ORIGIN 1900
612 /* Yield A - B, measured in seconds. */
617 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
618 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
619 /* Some compilers can't handle this as a single return statement. */
621 /* difference in day of year */
622 a
->tm_yday
- b
->tm_yday
623 /* + intervening leap days */
624 + ((ay
>> 2) - (by
>> 2))
626 + ((ay
/100 >> 2) - (by
/100 >> 2))
627 /* + difference in years * 365 */
628 + (long)(ay
-by
) * 365
630 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
631 + (a
->tm_min
- b
->tm_min
))
632 + (a
->tm_sec
- b
->tm_sec
));
635 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
636 "Return the offset and name for the local time zone.\n\
637 This returns a list of the form (OFFSET NAME).\n\
638 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
639 A negative value means west of Greenwich.\n\
640 NAME is a string giving the name of the time zone.\n\
641 If an argument is given, it specifies when the time zone offset is determined\n\
642 instead of using the current time. The argument should have the form:\n\
645 (HIGH LOW . IGNORED).\n\
646 Thus, you can use times obtained from `current-time'\n\
647 and from `file-attributes'.\n\
649 Some operating systems cannot provide all this information to Emacs;\n\
650 in this case, `current-time-zone' returns a list containing nil for\n\
651 the data it can't find.")
653 Lisp_Object specified_time
;
658 if (lisp_time_argument (specified_time
, &value
)
659 && (t
= gmtime (&value
)) != 0)
665 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
666 t
= localtime (&value
);
667 offset
= difftm (t
, &gmt
);
672 #else /* not HAVE_TM_ZONE */
674 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
675 s
= tzname
[t
->tm_isdst
];
677 #endif /* not HAVE_TM_ZONE */
680 /* No local time zone name is available; use "+-NNNN" instead. */
681 int am
= (offset
< 0 ? -offset
: offset
) / 60;
682 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
685 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
688 return Fmake_list (2, Qnil
);
700 /* Callers passing one argument to Finsert need not gcpro the
701 argument "array", since the only element of the array will
702 not be used after calling insert or insert_from_string, so
703 we don't care if it gets trashed. */
705 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
706 "Insert the arguments, either strings or characters, at point.\n\
707 Point moves forward so that it ends up after the inserted text.\n\
708 Any other markers at the point of insertion remain before the text.")
711 register Lisp_Object
*args
;
714 register Lisp_Object tem
;
717 for (argnum
= 0; argnum
< nargs
; argnum
++)
721 if (XTYPE (tem
) == Lisp_Int
)
726 else if (XTYPE (tem
) == Lisp_String
)
728 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
732 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
740 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
742 "Insert the arguments at point, inheriting properties from adjoining text.\n\
743 Point moves forward so that it ends up after the inserted text.\n\
744 Any other markers at the point of insertion remain before the text.")
747 register Lisp_Object
*args
;
750 register Lisp_Object tem
;
753 for (argnum
= 0; argnum
< nargs
; argnum
++)
757 if (XTYPE (tem
) == Lisp_Int
)
762 else if (XTYPE (tem
) == Lisp_String
)
764 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
768 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
776 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
777 "Insert strings or characters at point, relocating markers after the text.\n\
778 Point moves forward so that it ends up after the inserted text.\n\
779 Any other markers at the point of insertion also end up after the text.")
782 register Lisp_Object
*args
;
785 register Lisp_Object tem
;
788 for (argnum
= 0; argnum
< nargs
; argnum
++)
792 if (XTYPE (tem
) == Lisp_Int
)
795 insert_before_markers (str
, 1);
797 else if (XTYPE (tem
) == Lisp_String
)
799 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
803 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
811 DEFUN ("insert-before-markers-and-inherit",
812 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
814 "Insert text at point, relocating markers and inheriting properties.\n\
815 Point moves forward so that it ends up after the inserted text.\n\
816 Any other markers at the point of insertion also end up after the text.")
819 register Lisp_Object
*args
;
822 register Lisp_Object tem
;
825 for (argnum
= 0; argnum
< nargs
; argnum
++)
829 if (XTYPE (tem
) == Lisp_Int
)
832 insert_before_markers (str
, 1);
834 else if (XTYPE (tem
) == Lisp_String
)
836 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
840 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
848 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
849 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
850 Point and all markers are affected as in the function `insert'.\n\
851 Both arguments are required.")
853 Lisp_Object chr
, count
;
855 register unsigned char *string
;
859 CHECK_NUMBER (chr
, 0);
860 CHECK_NUMBER (count
, 1);
865 strlen
= min (n
, 256);
866 string
= (unsigned char *) alloca (strlen
);
867 for (i
= 0; i
< strlen
; i
++)
868 string
[i
] = XFASTINT (chr
);
871 insert (string
, strlen
);
880 /* Making strings from buffer contents. */
882 /* Return a Lisp_String containing the text of the current buffer from
883 START to END. If text properties are in use and the current buffer
884 has properties in the range specified, the resulting string will also
887 We don't want to use plain old make_string here, because it calls
888 make_uninit_string, which can cause the buffer arena to be
889 compacted. make_string has no way of knowing that the data has
890 been moved, and thus copies the wrong data into the string. This
891 doesn't effect most of the other users of make_string, so it should
892 be left as is. But we should use this function when conjuring
893 buffer substrings. */
896 make_buffer_string (start
, end
)
899 Lisp_Object result
, tem
;
901 if (start
< GPT
&& GPT
< end
)
904 result
= make_uninit_string (end
- start
);
905 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
907 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
909 #ifdef USE_TEXT_PROPERTIES
910 if (XINT (tem
) != end
)
911 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
917 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
918 "Return the contents of part of the current buffer as a string.\n\
919 The two arguments START and END are character positions;\n\
920 they can be in either order.")
924 register int beg
, end
;
926 validate_region (&b
, &e
);
930 return make_buffer_string (beg
, end
);
933 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
934 "Return the contents of the current buffer as a string.")
937 return make_buffer_string (BEGV
, ZV
);
940 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
942 "Insert before point a substring of the contents of buffer BUFFER.\n\
943 BUFFER may be a buffer or a buffer name.\n\
944 Arguments START and END are character numbers specifying the substring.\n\
945 They default to the beginning and the end of BUFFER.")
947 Lisp_Object buf
, b
, e
;
949 register int beg
, end
, temp
, len
, opoint
, start
;
950 register struct buffer
*bp
;
953 buffer
= Fget_buffer (buf
);
956 bp
= XBUFFER (buffer
);
962 CHECK_NUMBER_COERCE_MARKER (b
, 0);
969 CHECK_NUMBER_COERCE_MARKER (e
, 1);
974 temp
= beg
, beg
= end
, end
= temp
;
976 /* Move the gap or create enough gap in the current buffer. */
980 if (GAP_SIZE
< end
- beg
)
981 make_gap (end
- beg
- GAP_SIZE
);
987 if (!(BUF_BEGV (bp
) <= beg
989 && end
<= BUF_ZV (bp
)))
990 args_out_of_range (b
, e
);
992 /* Now the actual insertion will not do any gap motion,
993 so it matters not if BUF is the current buffer. */
994 if (beg
< BUF_GPT (bp
))
996 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
997 beg
= min (end
, BUF_GPT (bp
));
1000 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
1002 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
1003 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
1004 opoint
, len
, current_buffer
, 0);
1009 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1011 "Compare two substrings of two buffers; return result as number.\n\
1012 the value is -N if first string is less after N-1 chars,\n\
1013 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1014 Each substring is represented as three arguments: BUFFER, START and END.\n\
1015 That makes six args in all, three for each substring.\n\n\
1016 The value of `case-fold-search' in the current buffer\n\
1017 determines whether case is significant or ignored.")
1018 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1019 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1021 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1022 register struct buffer
*bp1
, *bp2
;
1023 register unsigned char *trt
1024 = (!NILP (current_buffer
->case_fold_search
)
1025 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1027 /* Find the first buffer and its substring. */
1030 bp1
= current_buffer
;
1034 buf1
= Fget_buffer (buffer1
);
1037 bp1
= XBUFFER (buf1
);
1041 begp1
= BUF_BEGV (bp1
);
1044 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1045 begp1
= XINT (start1
);
1048 endp1
= BUF_ZV (bp1
);
1051 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1052 endp1
= XINT (end1
);
1056 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1058 if (!(BUF_BEGV (bp1
) <= begp1
1060 && endp1
<= BUF_ZV (bp1
)))
1061 args_out_of_range (start1
, end1
);
1063 /* Likewise for second substring. */
1066 bp2
= current_buffer
;
1070 buf2
= Fget_buffer (buffer2
);
1073 bp2
= XBUFFER (buffer2
);
1077 begp2
= BUF_BEGV (bp2
);
1080 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1081 begp2
= XINT (start2
);
1084 endp2
= BUF_ZV (bp2
);
1087 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1088 endp2
= XINT (end2
);
1092 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1094 if (!(BUF_BEGV (bp2
) <= begp2
1096 && endp2
<= BUF_ZV (bp2
)))
1097 args_out_of_range (start2
, end2
);
1099 len1
= endp1
- begp1
;
1100 len2
= endp2
- begp2
;
1105 for (i
= 0; i
< length
; i
++)
1107 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1108 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1115 return make_number (- 1 - i
);
1117 return make_number (i
+ 1);
1120 /* The strings match as far as they go.
1121 If one is shorter, that one is less. */
1123 return make_number (length
+ 1);
1124 else if (length
< len2
)
1125 return make_number (- length
- 1);
1127 /* Same length too => they are equal. */
1128 return make_number (0);
1131 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1132 Ssubst_char_in_region
, 4, 5, 0,
1133 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1134 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1135 and don't mark the buffer as really changed.")
1136 (start
, end
, fromchar
, tochar
, noundo
)
1137 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1139 register int pos
, stop
, look
;
1142 validate_region (&start
, &end
);
1143 CHECK_NUMBER (fromchar
, 2);
1144 CHECK_NUMBER (tochar
, 3);
1148 look
= XINT (fromchar
);
1152 if (FETCH_CHAR (pos
) == look
)
1156 modify_region (current_buffer
, XINT (start
), stop
);
1158 if (! NILP (noundo
))
1160 if (MODIFF
- 1 == current_buffer
->save_modified
)
1161 current_buffer
->save_modified
++;
1162 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1163 current_buffer
->auto_save_modified
++;
1170 record_change (pos
, 1);
1171 FETCH_CHAR (pos
) = XINT (tochar
);
1177 signal_after_change (XINT (start
),
1178 stop
- XINT (start
), stop
- XINT (start
));
1183 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1184 "From START to END, translate characters according to TABLE.\n\
1185 TABLE is a string; the Nth character in it is the mapping\n\
1186 for the character with code N. Returns the number of characters changed.")
1190 register Lisp_Object table
;
1192 register int pos
, stop
; /* Limits of the region. */
1193 register unsigned char *tt
; /* Trans table. */
1194 register int oc
; /* Old character. */
1195 register int nc
; /* New character. */
1196 int cnt
; /* Number of changes made. */
1197 Lisp_Object z
; /* Return. */
1198 int size
; /* Size of translate table. */
1200 validate_region (&start
, &end
);
1201 CHECK_STRING (table
, 2);
1203 size
= XSTRING (table
)->size
;
1204 tt
= XSTRING (table
)->data
;
1208 modify_region (current_buffer
, pos
, stop
);
1211 for (; pos
< stop
; ++pos
)
1213 oc
= FETCH_CHAR (pos
);
1219 record_change (pos
, 1);
1220 FETCH_CHAR (pos
) = nc
;
1221 signal_after_change (pos
, 1, 1);
1231 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1232 "Delete the text between point and mark.\n\
1233 When called from a program, expects two arguments,\n\
1234 positions (integers or markers) specifying the stretch to be deleted.")
1238 validate_region (&b
, &e
);
1239 del_range (XINT (b
), XINT (e
));
1243 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1244 "Remove restrictions (narrowing) from current buffer.\n\
1245 This allows the buffer's full text to be seen and edited.")
1249 SET_BUF_ZV (current_buffer
, Z
);
1251 /* Changing the buffer bounds invalidates any recorded current column. */
1252 invalidate_current_column ();
1256 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1257 "Restrict editing in this buffer to the current region.\n\
1258 The rest of the text becomes temporarily invisible and untouchable\n\
1259 but is not deleted; if you save the buffer in a file, the invisible\n\
1260 text is included in the file. \\[widen] makes all visible again.\n\
1261 See also `save-restriction'.\n\
1263 When calling from a program, pass two arguments; positions (integers\n\
1264 or markers) bounding the text that should remain visible.")
1266 register Lisp_Object b
, e
;
1270 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1271 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1273 if (XINT (b
) > XINT (e
))
1280 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1281 args_out_of_range (b
, e
);
1283 BEGV
= XFASTINT (b
);
1284 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1285 if (point
< XFASTINT (b
))
1286 SET_PT (XFASTINT (b
));
1287 if (point
> XFASTINT (e
))
1288 SET_PT (XFASTINT (e
));
1290 /* Changing the buffer bounds invalidates any recorded current column. */
1291 invalidate_current_column ();
1296 save_restriction_save ()
1298 register Lisp_Object bottom
, top
;
1299 /* Note: I tried using markers here, but it does not win
1300 because insertion at the end of the saved region
1301 does not advance mh and is considered "outside" the saved region. */
1302 XFASTINT (bottom
) = BEGV
- BEG
;
1303 XFASTINT (top
) = Z
- ZV
;
1305 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1309 save_restriction_restore (data
)
1312 register struct buffer
*buf
;
1313 register int newhead
, newtail
;
1314 register Lisp_Object tem
;
1316 buf
= XBUFFER (XCONS (data
)->car
);
1318 data
= XCONS (data
)->cdr
;
1320 tem
= XCONS (data
)->car
;
1321 newhead
= XINT (tem
);
1322 tem
= XCONS (data
)->cdr
;
1323 newtail
= XINT (tem
);
1324 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1329 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1330 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1333 /* If point is outside the new visible range, move it inside. */
1335 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1340 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1341 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1342 The buffer's restrictions make parts of the beginning and end invisible.\n\
1343 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1344 This special form, `save-restriction', saves the current buffer's restrictions\n\
1345 when it is entered, and restores them when it is exited.\n\
1346 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1347 The old restrictions settings are restored\n\
1348 even in case of abnormal exit (throw or error).\n\
1350 The value returned is the value of the last form in BODY.\n\
1352 `save-restriction' can get confused if, within the BODY, you widen\n\
1353 and then make changes outside the area within the saved restrictions.\n\
1355 Note: if you are using both `save-excursion' and `save-restriction',\n\
1356 use `save-excursion' outermost:\n\
1357 (save-excursion (save-restriction ...))")
1361 register Lisp_Object val
;
1362 int count
= specpdl_ptr
- specpdl
;
1364 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1365 val
= Fprogn (body
);
1366 return unbind_to (count
, val
);
1369 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1370 "Print a one-line message at the bottom of the screen.\n\
1371 The first argument is a control string.\n\
1372 It may contain %s or %d or %c to print successive following arguments.\n\
1373 %s means print an argument as a string, %d means print as number in decimal,\n\
1374 %c means print a number as a single character.\n\
1375 The argument used by %s must be a string or a symbol;\n\
1376 the argument used by %d or %c must be a number.\n\
1377 If the first argument is nil, clear any existing message; let the\n\
1378 minibuffer contents show.")
1390 register Lisp_Object val
;
1391 val
= Fformat (nargs
, args
);
1392 message2 (XSTRING (val
)->data
, XSTRING (val
)->size
);
1397 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1398 "Format a string out of a control-string and arguments.\n\
1399 The first argument is a control string.\n\
1400 The other arguments are substituted into it to make the result, a string.\n\
1401 It may contain %-sequences meaning to substitute the next argument.\n\
1402 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1403 %d means print as number in decimal (%o octal, %x hex).\n\
1404 %c means print a number as a single character.\n\
1405 %S means print any object as an s-expression (using prin1).\n\
1406 The argument used for %d, %o, %x or %c must be a number.\n\
1407 Use %% to put a single % into the output.")
1410 register Lisp_Object
*args
;
1412 register int n
; /* The number of the next arg to substitute */
1413 register int total
= 5; /* An estimate of the final length */
1415 register unsigned char *format
, *end
;
1417 extern char *index ();
1418 /* It should not be necessary to GCPRO ARGS, because
1419 the caller in the interpreter should take care of that. */
1421 CHECK_STRING (args
[0], 0);
1422 format
= XSTRING (args
[0])->data
;
1423 end
= format
+ XSTRING (args
[0])->size
;
1426 while (format
!= end
)
1427 if (*format
++ == '%')
1431 /* Process a numeric arg and skip it. */
1432 minlen
= atoi (format
);
1437 while ((*format
>= '0' && *format
<= '9')
1438 || *format
== '-' || *format
== ' ' || *format
== '.')
1443 else if (++n
>= nargs
)
1445 else if (*format
== 'S')
1447 /* For `S', prin1 the argument and then treat like a string. */
1448 register Lisp_Object tem
;
1449 tem
= Fprin1_to_string (args
[n
], Qnil
);
1453 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1455 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1458 else if (XTYPE (args
[n
]) == Lisp_String
)
1461 total
+= XSTRING (args
[n
])->size
;
1463 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1464 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1466 #ifdef LISP_FLOAT_TYPE
1467 /* The following loop assumes the Lisp type indicates
1468 the proper way to pass the argument.
1469 So make sure we have a flonum if the argument should
1471 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1472 args
[n
] = Ffloat (args
[n
]);
1476 #ifdef LISP_FLOAT_TYPE
1477 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1479 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1480 args
[n
] = Ftruncate (args
[n
]);
1486 /* Anything but a string, convert to a string using princ. */
1487 register Lisp_Object tem
;
1488 tem
= Fprin1_to_string (args
[n
], Qt
);
1495 register int nstrings
= n
+ 1;
1497 /* Allocate twice as many strings as we have %-escapes; floats occupy
1498 two slots, and we're not sure how many of those we have. */
1499 register unsigned char **strings
1500 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1504 for (n
= 0; n
< nstrings
; n
++)
1507 strings
[i
++] = (unsigned char *) "";
1508 else if (XTYPE (args
[n
]) == Lisp_Int
)
1509 /* We checked above that the corresponding format effector
1510 isn't %s, which would cause MPV. */
1511 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1512 #ifdef LISP_FLOAT_TYPE
1513 else if (XTYPE (args
[n
]) == Lisp_Float
)
1515 union { double d
; int half
[2]; } u
;
1517 u
.d
= XFLOAT (args
[n
])->data
;
1518 strings
[i
++] = (unsigned char *) u
.half
[0];
1519 strings
[i
++] = (unsigned char *) u
.half
[1];
1523 strings
[i
++] = XSTRING (args
[n
])->data
;
1526 /* Format it in bigger and bigger buf's until it all fits. */
1529 buf
= (char *) alloca (total
+ 1);
1532 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1533 if (buf
[total
- 1] == 0)
1541 return make_string (buf
, length
);
1547 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1548 int arg0
, arg1
, arg2
, arg3
, arg4
;
1562 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1564 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1566 return build_string (buf
);
1569 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1570 "Return t if two characters match, optionally ignoring case.\n\
1571 Both arguments must be characters (i.e. integers).\n\
1572 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1574 register Lisp_Object c1
, c2
;
1576 unsigned char *downcase
= DOWNCASE_TABLE
;
1577 CHECK_NUMBER (c1
, 0);
1578 CHECK_NUMBER (c2
, 1);
1580 if (!NILP (current_buffer
->case_fold_search
)
1581 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1582 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1583 : XINT (c1
) == XINT (c2
))
1592 staticpro (&Vuser_name
);
1593 staticpro (&Vuser_full_name
);
1594 staticpro (&Vuser_real_name
);
1595 staticpro (&Vsystem_name
);
1597 defsubr (&Schar_equal
);
1598 defsubr (&Sgoto_char
);
1599 defsubr (&Sstring_to_char
);
1600 defsubr (&Schar_to_string
);
1601 defsubr (&Sbuffer_substring
);
1602 defsubr (&Sbuffer_string
);
1604 defsubr (&Spoint_marker
);
1605 defsubr (&Smark_marker
);
1607 defsubr (&Sregion_beginning
);
1608 defsubr (&Sregion_end
);
1609 /* defsubr (&Smark); */
1610 /* defsubr (&Sset_mark); */
1611 defsubr (&Ssave_excursion
);
1613 defsubr (&Sbufsize
);
1614 defsubr (&Spoint_max
);
1615 defsubr (&Spoint_min
);
1616 defsubr (&Spoint_min_marker
);
1617 defsubr (&Spoint_max_marker
);
1623 defsubr (&Sfollowing_char
);
1624 defsubr (&Sprevious_char
);
1625 defsubr (&Schar_after
);
1627 defsubr (&Sinsert_before_markers
);
1628 defsubr (&Sinsert_and_inherit
);
1629 defsubr (&Sinsert_and_inherit_before_markers
);
1630 defsubr (&Sinsert_char
);
1632 defsubr (&Suser_login_name
);
1633 defsubr (&Suser_real_login_name
);
1634 defsubr (&Suser_uid
);
1635 defsubr (&Suser_real_uid
);
1636 defsubr (&Suser_full_name
);
1637 defsubr (&Semacs_pid
);
1638 defsubr (&Scurrent_time
);
1639 defsubr (&Scurrent_time_string
);
1640 defsubr (&Scurrent_time_zone
);
1641 defsubr (&Ssystem_name
);
1642 defsubr (&Smessage
);
1645 defsubr (&Sinsert_buffer_substring
);
1646 defsubr (&Scompare_buffer_substrings
);
1647 defsubr (&Ssubst_char_in_region
);
1648 defsubr (&Stranslate_region
);
1649 defsubr (&Sdelete_region
);
1651 defsubr (&Snarrow_to_region
);
1652 defsubr (&Ssave_restriction
);