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 a clipping 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 a clipping 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 a clipping restriction is in effect,\n\
382 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 a clipping restriction is in effect,\n\
393 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 ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
531 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
532 The time is returned as a list of three integers. The first has the\n\
533 most significant 16 bits of the seconds, while the second has the\n\
534 least significant 16 bits. The third integer gives the microsecond\n\
537 The microsecond count is zero on systems that do not provide\n\
538 resolution finer than a second.")
542 Lisp_Object result
[3];
545 XSET (result
[0], Lisp_Int
, (EMACS_SECS (t
) >> 16) & 0xffff);
546 XSET (result
[1], Lisp_Int
, (EMACS_SECS (t
) >> 0) & 0xffff);
547 XSET (result
[2], Lisp_Int
, EMACS_USECS (t
));
549 return Flist (3, result
);
554 lisp_time_argument (specified_time
, result
)
555 Lisp_Object specified_time
;
558 if (NILP (specified_time
))
559 return time (result
) != -1;
562 Lisp_Object high
, low
;
563 high
= Fcar (specified_time
);
564 CHECK_NUMBER (high
, 0);
565 low
= Fcdr (specified_time
);
566 if (XTYPE (low
) == Lisp_Cons
)
568 CHECK_NUMBER (low
, 0);
569 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
570 return *result
>> 16 == XINT (high
);
574 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
575 "Return the current time, as a human-readable string.\n\
576 Programs can use this function to decode a time,\n\
577 since the number of columns in each field is fixed.\n\
578 The format is `Sun Sep 16 01:03:52 1973'.\n\
579 If an argument is given, it specifies a time to format\n\
580 instead of the current time. The argument should have the form:\n\
583 (HIGH LOW . IGNORED).\n\
584 Thus, you can use times obtained from `current-time'\n\
585 and from `file-attributes'.")
587 Lisp_Object specified_time
;
593 if (! lisp_time_argument (specified_time
, &value
))
595 tem
= (char *) ctime (&value
);
597 strncpy (buf
, tem
, 24);
600 return build_string (buf
);
603 #define TM_YEAR_ORIGIN 1900
605 /* Yield A - B, measured in seconds. */
610 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
611 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
616 /* difference in day of year */
617 a
->tm_yday
- b
->tm_yday
618 /* + intervening leap days */
619 + ((ay
>> 2) - (by
>> 2))
621 + ((ay
/100 >> 2) - (by
/100 >> 2))
622 /* + difference in years * 365 */
623 + (long)(ay
-by
) * 365
624 )*24 + (a
->tm_hour
- b
->tm_hour
)
625 )*60 + (a
->tm_min
- b
->tm_min
)
626 )*60 + (a
->tm_sec
- b
->tm_sec
);
629 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
630 "Return the offset and name for the local time zone.\n\
631 This returns a list of the form (OFFSET NAME).\n\
632 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
633 A negative value means west of Greenwich.\n\
634 NAME is a string giving the name of the time zone.\n\
635 If an argument is given, it specifies when the time zone offset is determined\n\
636 instead of using the current time. The argument should have the form:\n\
639 (HIGH LOW . IGNORED).\n\
640 Thus, you can use times obtained from `current-time'\n\
641 and from `file-attributes'.\n\
643 Some operating systems cannot provide all this information to Emacs;\n\
644 in this case, `current-time-zone' returns a list containing nil for\n\
645 the data it can't find.")
647 Lisp_Object specified_time
;
652 if (lisp_time_argument (specified_time
, &value
)
653 && (t
= gmtime (&value
)) != 0)
659 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
660 t
= localtime (&value
);
661 offset
= difftm (t
, &gmt
);
666 #else /* not HAVE_TM_ZONE */
668 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
669 s
= tzname
[t
->tm_isdst
];
671 #endif /* not HAVE_TM_ZONE */
674 /* No local time zone name is available; use "+-NNNN" instead. */
675 int am
= (offset
< 0 ? -offset
: offset
) / 60;
676 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
679 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
682 return Fmake_list (2, Qnil
);
694 /* Callers passing one argument to Finsert need not gcpro the
695 argument "array", since the only element of the array will
696 not be used after calling insert or insert_from_string, so
697 we don't care if it gets trashed. */
699 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
700 "Insert the arguments, either strings or characters, at point.\n\
701 Point moves forward so that it ends up after the inserted text.\n\
702 Any other markers at the point of insertion remain before the text.")
705 register Lisp_Object
*args
;
708 register Lisp_Object tem
;
711 for (argnum
= 0; argnum
< nargs
; argnum
++)
715 if (XTYPE (tem
) == Lisp_Int
)
720 else if (XTYPE (tem
) == Lisp_String
)
722 insert_from_string (tem
, 0, XSTRING (tem
)->size
);
726 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
734 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
735 "Insert strings or characters at point, relocating markers after the text.\n\
736 Point moves forward so that it ends up after the inserted text.\n\
737 Any other markers at the point of insertion also end up after the text.")
740 register Lisp_Object
*args
;
743 register Lisp_Object tem
;
746 for (argnum
= 0; argnum
< nargs
; argnum
++)
750 if (XTYPE (tem
) == Lisp_Int
)
753 insert_before_markers (str
, 1);
755 else if (XTYPE (tem
) == Lisp_String
)
757 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
);
761 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
769 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 2, 0,
770 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
771 Point and all markers are affected as in the function `insert'.\n\
772 Both arguments are required.")
774 Lisp_Object chr
, count
;
776 register unsigned char *string
;
780 CHECK_NUMBER (chr
, 0);
781 CHECK_NUMBER (count
, 1);
786 strlen
= min (n
, 256);
787 string
= (unsigned char *) alloca (strlen
);
788 for (i
= 0; i
< strlen
; i
++)
789 string
[i
] = XFASTINT (chr
);
792 insert (string
, strlen
);
801 /* Making strings from buffer contents. */
803 /* Return a Lisp_String containing the text of the current buffer from
804 START to END. If text properties are in use and the current buffer
805 has properties in the range specified, the resulting string will also
808 We don't want to use plain old make_string here, because it calls
809 make_uninit_string, which can cause the buffer arena to be
810 compacted. make_string has no way of knowing that the data has
811 been moved, and thus copies the wrong data into the string. This
812 doesn't effect most of the other users of make_string, so it should
813 be left as is. But we should use this function when conjuring
814 buffer substrings. */
817 make_buffer_string (start
, end
)
822 if (start
< GPT
&& GPT
< end
)
825 result
= make_uninit_string (end
- start
);
826 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
828 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
829 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
834 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
835 "Return the contents of part of the current buffer as a string.\n\
836 The two arguments START and END are character positions;\n\
837 they can be in either order.")
841 register int beg
, end
;
843 validate_region (&b
, &e
);
847 return make_buffer_string (beg
, end
);
850 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
851 "Return the contents of the current buffer as a string.")
854 return make_buffer_string (BEGV
, ZV
);
857 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
859 "Insert before point a substring of the contents of buffer BUFFER.\n\
860 BUFFER may be a buffer or a buffer name.\n\
861 Arguments START and END are character numbers specifying the substring.\n\
862 They default to the beginning and the end of BUFFER.")
864 Lisp_Object buf
, b
, e
;
866 register int beg
, end
, temp
, len
, opoint
, start
;
867 register struct buffer
*bp
;
870 buffer
= Fget_buffer (buf
);
873 bp
= XBUFFER (buffer
);
879 CHECK_NUMBER_COERCE_MARKER (b
, 0);
886 CHECK_NUMBER_COERCE_MARKER (e
, 1);
891 temp
= beg
, beg
= end
, end
= temp
;
893 /* Move the gap or create enough gap in the current buffer. */
897 if (GAP_SIZE
< end
- beg
)
898 make_gap (end
- beg
- GAP_SIZE
);
904 if (!(BUF_BEGV (bp
) <= beg
906 && end
<= BUF_ZV (bp
)))
907 args_out_of_range (b
, e
);
909 /* Now the actual insertion will not do any gap motion,
910 so it matters not if BUF is the current buffer. */
911 if (beg
< BUF_GPT (bp
))
913 insert (BUF_CHAR_ADDRESS (bp
, beg
), min (end
, BUF_GPT (bp
)) - beg
);
914 beg
= min (end
, BUF_GPT (bp
));
917 insert (BUF_CHAR_ADDRESS (bp
, beg
), end
- beg
);
919 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
920 graft_intervals_into_buffer (copy_intervals (bp
->intervals
, start
, len
),
926 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
928 "Compare two substrings of two buffers; return result as number.\n\
929 the value is -N if first string is less after N-1 chars,\n\
930 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
931 Each substring is represented as three arguments: BUFFER, START and END.\n\
932 That makes six args in all, three for each substring.\n\n\
933 The value of `case-fold-search' in the current buffer\n\
934 determines whether case is significant or ignored.")
935 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
936 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
938 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
939 register struct buffer
*bp1
, *bp2
;
940 register unsigned char *trt
941 = (!NILP (current_buffer
->case_fold_search
)
942 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
944 /* Find the first buffer and its substring. */
947 bp1
= current_buffer
;
951 buf1
= Fget_buffer (buffer1
);
954 bp1
= XBUFFER (buf1
);
958 begp1
= BUF_BEGV (bp1
);
961 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
962 begp1
= XINT (start1
);
965 endp1
= BUF_ZV (bp1
);
968 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
973 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
975 if (!(BUF_BEGV (bp1
) <= begp1
977 && endp1
<= BUF_ZV (bp1
)))
978 args_out_of_range (start1
, end1
);
980 /* Likewise for second substring. */
983 bp2
= current_buffer
;
987 buf2
= Fget_buffer (buffer2
);
990 bp2
= XBUFFER (buffer2
);
994 begp2
= BUF_BEGV (bp2
);
997 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
998 begp2
= XINT (start2
);
1001 endp2
= BUF_ZV (bp2
);
1004 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1005 endp2
= XINT (end2
);
1009 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1011 if (!(BUF_BEGV (bp2
) <= begp2
1013 && endp2
<= BUF_ZV (bp2
)))
1014 args_out_of_range (start2
, end2
);
1016 len1
= endp1
- begp1
;
1017 len2
= endp2
- begp2
;
1022 for (i
= 0; i
< length
; i
++)
1024 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1025 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1032 return make_number (- 1 - i
);
1034 return make_number (i
+ 1);
1037 /* The strings match as far as they go.
1038 If one is shorter, that one is less. */
1040 return make_number (length
+ 1);
1041 else if (length
< len2
)
1042 return make_number (- length
- 1);
1044 /* Same length too => they are equal. */
1045 return make_number (0);
1048 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1049 Ssubst_char_in_region
, 4, 5, 0,
1050 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1051 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1052 and don't mark the buffer as really changed.")
1053 (start
, end
, fromchar
, tochar
, noundo
)
1054 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1056 register int pos
, stop
, look
;
1058 validate_region (&start
, &end
);
1059 CHECK_NUMBER (fromchar
, 2);
1060 CHECK_NUMBER (tochar
, 3);
1064 look
= XINT (fromchar
);
1066 modify_region (current_buffer
, pos
, stop
);
1067 if (! NILP (noundo
))
1069 if (MODIFF
- 1 == current_buffer
->save_modified
)
1070 current_buffer
->save_modified
++;
1071 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1072 current_buffer
->auto_save_modified
++;
1077 if (FETCH_CHAR (pos
) == look
)
1080 record_change (pos
, 1);
1081 FETCH_CHAR (pos
) = XINT (tochar
);
1083 signal_after_change (pos
, 1, 1);
1091 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1092 "From START to END, translate characters according to TABLE.\n\
1093 TABLE is a string; the Nth character in it is the mapping\n\
1094 for the character with code N. Returns the number of characters changed.")
1098 register Lisp_Object table
;
1100 register int pos
, stop
; /* Limits of the region. */
1101 register unsigned char *tt
; /* Trans table. */
1102 register int oc
; /* Old character. */
1103 register int nc
; /* New character. */
1104 int cnt
; /* Number of changes made. */
1105 Lisp_Object z
; /* Return. */
1106 int size
; /* Size of translate table. */
1108 validate_region (&start
, &end
);
1109 CHECK_STRING (table
, 2);
1111 size
= XSTRING (table
)->size
;
1112 tt
= XSTRING (table
)->data
;
1116 modify_region (current_buffer
, pos
, stop
);
1119 for (; pos
< stop
; ++pos
)
1121 oc
= FETCH_CHAR (pos
);
1127 record_change (pos
, 1);
1128 FETCH_CHAR (pos
) = nc
;
1129 signal_after_change (pos
, 1, 1);
1139 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1140 "Delete the text between point and mark.\n\
1141 When called from a program, expects two arguments,\n\
1142 positions (integers or markers) specifying the stretch to be deleted.")
1146 validate_region (&b
, &e
);
1147 del_range (XINT (b
), XINT (e
));
1151 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1152 "Remove restrictions (narrowing) from current buffer.\n\
1153 This allows the buffer's full text to be seen and edited.")
1157 SET_BUF_ZV (current_buffer
, Z
);
1159 /* Changing the buffer bounds invalidates any recorded current column. */
1160 invalidate_current_column ();
1164 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1165 "Restrict editing in this buffer to the current region.\n\
1166 The rest of the text becomes temporarily invisible and untouchable\n\
1167 but is not deleted; if you save the buffer in a file, the invisible\n\
1168 text is included in the file. \\[widen] makes all visible again.\n\
1169 See also `save-restriction'.\n\
1171 When calling from a program, pass two arguments; positions (integers\n\
1172 or markers) bounding the text that should remain visible.")
1174 register Lisp_Object b
, e
;
1178 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1179 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1181 if (XINT (b
) > XINT (e
))
1188 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1189 args_out_of_range (b
, e
);
1191 BEGV
= XFASTINT (b
);
1192 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1193 if (point
< XFASTINT (b
))
1194 SET_PT (XFASTINT (b
));
1195 if (point
> XFASTINT (e
))
1196 SET_PT (XFASTINT (e
));
1198 /* Changing the buffer bounds invalidates any recorded current column. */
1199 invalidate_current_column ();
1204 save_restriction_save ()
1206 register Lisp_Object bottom
, top
;
1207 /* Note: I tried using markers here, but it does not win
1208 because insertion at the end of the saved region
1209 does not advance mh and is considered "outside" the saved region. */
1210 XFASTINT (bottom
) = BEGV
- BEG
;
1211 XFASTINT (top
) = Z
- ZV
;
1213 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1217 save_restriction_restore (data
)
1220 register struct buffer
*buf
;
1221 register int newhead
, newtail
;
1222 register Lisp_Object tem
;
1224 buf
= XBUFFER (XCONS (data
)->car
);
1226 data
= XCONS (data
)->cdr
;
1228 tem
= XCONS (data
)->car
;
1229 newhead
= XINT (tem
);
1230 tem
= XCONS (data
)->cdr
;
1231 newtail
= XINT (tem
);
1232 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1237 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1238 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1241 /* If point is outside the new visible range, move it inside. */
1243 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1248 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1249 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1250 The buffer's restrictions make parts of the beginning and end invisible.\n\
1251 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1252 This special form, `save-restriction', saves the current buffer's restrictions\n\
1253 when it is entered, and restores them when it is exited.\n\
1254 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1255 The old restrictions settings are restored\n\
1256 even in case of abnormal exit (throw or error).\n\
1258 The value returned is the value of the last form in BODY.\n\
1260 `save-restriction' can get confused if, within the BODY, you widen\n\
1261 and then make changes outside the area within the saved restrictions.\n\
1263 Note: if you are using both `save-excursion' and `save-restriction',\n\
1264 use `save-excursion' outermost:\n\
1265 (save-excursion (save-restriction ...))")
1269 register Lisp_Object val
;
1270 int count
= specpdl_ptr
- specpdl
;
1272 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1273 val
= Fprogn (body
);
1274 return unbind_to (count
, val
);
1277 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1278 "Print a one-line message at the bottom of the screen.\n\
1279 The first argument is a control string.\n\
1280 It may contain %s or %d or %c to print successive following arguments.\n\
1281 %s means print an argument as a string, %d means print as number in decimal,\n\
1282 %c means print a number as a single character.\n\
1283 The argument used by %s must be a string or a symbol;\n\
1284 the argument used by %d or %c must be a number.\n\
1285 If the first argument is nil, clear any existing message; let the\n\
1286 minibuffer contents show.")
1298 register Lisp_Object val
;
1299 val
= Fformat (nargs
, args
);
1300 message ("%s", XSTRING (val
)->data
);
1305 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1306 "Format a string out of a control-string and arguments.\n\
1307 The first argument is a control string.\n\
1308 The other arguments are substituted into it to make the result, a string.\n\
1309 It may contain %-sequences meaning to substitute the next argument.\n\
1310 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1311 %d means print as number in decimal (%o octal, %x hex).\n\
1312 %c means print a number as a single character.\n\
1313 %S means print any object as an s-expression (using prin1).\n\
1314 The argument used for %d, %o, %x or %c must be a number.\n\
1315 Use %% to put a single % into the output.")
1318 register Lisp_Object
*args
;
1320 register int n
; /* The number of the next arg to substitute */
1321 register int total
= 5; /* An estimate of the final length */
1323 register unsigned char *format
, *end
;
1325 extern char *index ();
1326 /* It should not be necessary to GCPRO ARGS, because
1327 the caller in the interpreter should take care of that. */
1329 CHECK_STRING (args
[0], 0);
1330 format
= XSTRING (args
[0])->data
;
1331 end
= format
+ XSTRING (args
[0])->size
;
1334 while (format
!= end
)
1335 if (*format
++ == '%')
1339 /* Process a numeric arg and skip it. */
1340 minlen
= atoi (format
);
1345 while ((*format
>= '0' && *format
<= '9')
1346 || *format
== '-' || *format
== ' ' || *format
== '.')
1351 else if (++n
>= nargs
)
1353 else if (*format
== 'S')
1355 /* For `S', prin1 the argument and then treat like a string. */
1356 register Lisp_Object tem
;
1357 tem
= Fprin1_to_string (args
[n
], Qnil
);
1361 else if (XTYPE (args
[n
]) == Lisp_Symbol
)
1363 XSET (args
[n
], Lisp_String
, XSYMBOL (args
[n
])->name
);
1366 else if (XTYPE (args
[n
]) == Lisp_String
)
1369 total
+= XSTRING (args
[n
])->size
;
1371 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1372 else if (XTYPE (args
[n
]) == Lisp_Int
&& *format
!= 's')
1374 #ifdef LISP_FLOAT_TYPE
1375 /* The following loop assumes the Lisp type indicates
1376 the proper way to pass the argument.
1377 So make sure we have a flonum if the argument should
1379 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1380 args
[n
] = Ffloat (args
[n
]);
1384 #ifdef LISP_FLOAT_TYPE
1385 else if (XTYPE (args
[n
]) == Lisp_Float
&& *format
!= 's')
1387 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1388 args
[n
] = Ftruncate (args
[n
]);
1394 /* Anything but a string, convert to a string using princ. */
1395 register Lisp_Object tem
;
1396 tem
= Fprin1_to_string (args
[n
], Qt
);
1403 register int nstrings
= n
+ 1;
1405 /* Allocate twice as many strings as we have %-escapes; floats occupy
1406 two slots, and we're not sure how many of those we have. */
1407 register unsigned char **strings
1408 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1412 for (n
= 0; n
< nstrings
; n
++)
1415 strings
[i
++] = (unsigned char *) "";
1416 else if (XTYPE (args
[n
]) == Lisp_Int
)
1417 /* We checked above that the corresponding format effector
1418 isn't %s, which would cause MPV. */
1419 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1420 #ifdef LISP_FLOAT_TYPE
1421 else if (XTYPE (args
[n
]) == Lisp_Float
)
1423 union { double d
; int half
[2]; } u
;
1425 u
.d
= XFLOAT (args
[n
])->data
;
1426 strings
[i
++] = (unsigned char *) u
.half
[0];
1427 strings
[i
++] = (unsigned char *) u
.half
[1];
1431 strings
[i
++] = XSTRING (args
[n
])->data
;
1434 /* Format it in bigger and bigger buf's until it all fits. */
1437 buf
= (char *) alloca (total
+ 1);
1440 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1441 if (buf
[total
- 1] == 0)
1449 return make_string (buf
, length
);
1455 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1456 int arg0
, arg1
, arg2
, arg3
, arg4
;
1470 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1472 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1474 return build_string (buf
);
1477 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1478 "Return t if two characters match, optionally ignoring case.\n\
1479 Both arguments must be characters (i.e. integers).\n\
1480 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1482 register Lisp_Object c1
, c2
;
1484 unsigned char *downcase
= DOWNCASE_TABLE
;
1485 CHECK_NUMBER (c1
, 0);
1486 CHECK_NUMBER (c2
, 1);
1488 if (!NILP (current_buffer
->case_fold_search
)
1489 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1490 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1491 : XINT (c1
) == XINT (c2
))
1500 staticpro (&Vuser_name
);
1501 staticpro (&Vuser_full_name
);
1502 staticpro (&Vuser_real_name
);
1503 staticpro (&Vsystem_name
);
1505 defsubr (&Schar_equal
);
1506 defsubr (&Sgoto_char
);
1507 defsubr (&Sstring_to_char
);
1508 defsubr (&Schar_to_string
);
1509 defsubr (&Sbuffer_substring
);
1510 defsubr (&Sbuffer_string
);
1512 defsubr (&Spoint_marker
);
1513 defsubr (&Smark_marker
);
1515 defsubr (&Sregion_beginning
);
1516 defsubr (&Sregion_end
);
1517 /* defsubr (&Smark); */
1518 /* defsubr (&Sset_mark); */
1519 defsubr (&Ssave_excursion
);
1521 defsubr (&Sbufsize
);
1522 defsubr (&Spoint_max
);
1523 defsubr (&Spoint_min
);
1524 defsubr (&Spoint_min_marker
);
1525 defsubr (&Spoint_max_marker
);
1531 defsubr (&Sfollowing_char
);
1532 defsubr (&Sprevious_char
);
1533 defsubr (&Schar_after
);
1535 defsubr (&Sinsert_before_markers
);
1536 defsubr (&Sinsert_char
);
1538 defsubr (&Suser_login_name
);
1539 defsubr (&Suser_real_login_name
);
1540 defsubr (&Suser_uid
);
1541 defsubr (&Suser_real_uid
);
1542 defsubr (&Suser_full_name
);
1543 defsubr (&Scurrent_time
);
1544 defsubr (&Scurrent_time_string
);
1545 defsubr (&Scurrent_time_zone
);
1546 defsubr (&Ssystem_name
);
1547 defsubr (&Smessage
);
1550 defsubr (&Sinsert_buffer_substring
);
1551 defsubr (&Scompare_buffer_substrings
);
1552 defsubr (&Ssubst_char_in_region
);
1553 defsubr (&Stranslate_region
);
1554 defsubr (&Sdelete_region
);
1556 defsubr (&Snarrow_to_region
);
1557 defsubr (&Ssave_restriction
);