1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
21 #include <sys/types.h>
32 #include "intervals.h"
38 #define min(a, b) ((a) < (b) ? (a) : (b))
39 #define max(a, b) ((a) > (b) ? (a) : (b))
41 extern void insert_from_buffer ();
42 static long difftm ();
44 /* Some static data, and a function to initialize it for each run */
46 Lisp_Object Vsystem_name
;
47 Lisp_Object Vuser_real_name
; /* login name of current user ID */
48 Lisp_Object Vuser_full_name
; /* full name of current user */
49 Lisp_Object Vuser_name
; /* user name from LOGNAME or USER */
55 register unsigned char *p
, *q
, *r
;
56 struct passwd
*pw
; /* password entry for the current user */
57 extern char *index ();
60 /* Set up system_name even when dumping. */
64 /* Don't bother with this on initial start when just dumping out */
67 #endif /* not CANNOT_DUMP */
69 pw
= (struct passwd
*) getpwuid (getuid ());
71 /* We let the real user name default to "root" because that's quite
72 accurate on MSDOG and because it lets Emacs find the init file.
73 (The DVX libraries override the Djgpp libraries here.) */
74 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "root");
76 Vuser_real_name
= build_string (pw
? pw
->pw_name
: "unknown");
79 /* Get the effective user name, by consulting environment variables,
80 or the effective uid if those are unset. */
81 user_name
= (char *) getenv ("LOGNAME");
84 user_name
= (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
86 user_name
= (char *) getenv ("USER");
87 #endif /* WINDOWSNT */
90 pw
= (struct passwd
*) getpwuid (geteuid ());
91 user_name
= (char *) (pw
? pw
->pw_name
: "unknown");
93 Vuser_name
= build_string (user_name
);
95 /* If the user name claimed in the environment vars differs from
96 the real uid, use the claimed name to find the full name. */
97 tem
= Fstring_equal (Vuser_name
, Vuser_real_name
);
99 pw
= (struct passwd
*) getpwnam (XSTRING (Vuser_name
)->data
);
101 p
= (unsigned char *) (pw
? USER_FULL_NAME
: "unknown");
102 q
= (unsigned char *) index (p
, ',');
103 Vuser_full_name
= make_string (p
, q
? q
- p
: strlen (p
));
105 #ifdef AMPERSAND_FULL_NAME
106 p
= XSTRING (Vuser_full_name
)->data
;
107 q
= (char *) index (p
, '&');
108 /* Substitute the login name for the &, upcasing the first character. */
111 r
= (char *) alloca (strlen (p
) + XSTRING (Vuser_name
)->size
+ 1);
114 strcat (r
, XSTRING (Vuser_name
)->data
);
115 r
[q
- p
] = UPCASE (r
[q
- p
]);
117 Vuser_full_name
= build_string (r
);
119 #endif /* AMPERSAND_FULL_NAME */
122 DEFUN ("char-to-string", Fchar_to_string
, Schar_to_string
, 1, 1, 0,
123 "Convert arg CHAR to a one-character string containing that character.")
131 return make_string (&c
, 1);
134 DEFUN ("string-to-char", Fstring_to_char
, Sstring_to_char
, 1, 1, 0,
135 "Convert arg STRING to a character, the first character of that string.")
137 register Lisp_Object str
;
139 register Lisp_Object val
;
140 register struct Lisp_String
*p
;
141 CHECK_STRING (str
, 0);
145 XSETFASTINT (val
, ((unsigned char *) p
->data
)[0]);
147 XSETFASTINT (val
, 0);
155 register Lisp_Object mark
;
156 mark
= Fmake_marker ();
157 Fset_marker (mark
, make_number (val
), Qnil
);
161 DEFUN ("point", Fpoint
, Spoint
, 0, 0, 0,
162 "Return value of point, as an integer.\n\
163 Beginning of buffer is position (point-min)")
167 XSETFASTINT (temp
, point
);
171 DEFUN ("point-marker", Fpoint_marker
, Spoint_marker
, 0, 0, 0,
172 "Return value of point, as a marker object.")
175 return buildmark (point
);
179 clip_to_bounds (lower
, num
, upper
)
180 int lower
, num
, upper
;
184 else if (num
> upper
)
190 DEFUN ("goto-char", Fgoto_char
, Sgoto_char
, 1, 1, "NGoto char: ",
191 "Set point to POSITION, a number or marker.\n\
192 Beginning of buffer is position (point-min), end is (point-max).")
194 register Lisp_Object n
;
196 CHECK_NUMBER_COERCE_MARKER (n
, 0);
198 SET_PT (clip_to_bounds (BEGV
, XINT (n
), ZV
));
203 region_limit (beginningp
)
206 extern Lisp_Object Vmark_even_if_inactive
; /* Defined in callint.c. */
207 register Lisp_Object m
;
208 if (!NILP (Vtransient_mark_mode
) && NILP (Vmark_even_if_inactive
)
209 && NILP (current_buffer
->mark_active
))
210 Fsignal (Qmark_inactive
, Qnil
);
211 m
= Fmarker_position (current_buffer
->mark
);
212 if (NILP (m
)) error ("There is no region now");
213 if ((point
< XFASTINT (m
)) == beginningp
)
214 return (make_number (point
));
219 DEFUN ("region-beginning", Fregion_beginning
, Sregion_beginning
, 0, 0, 0,
220 "Return position of beginning of region, as an integer.")
223 return (region_limit (1));
226 DEFUN ("region-end", Fregion_end
, Sregion_end
, 0, 0, 0,
227 "Return position of end of region, as an integer.")
230 return (region_limit (0));
233 #if 0 /* now in lisp code */
234 DEFUN ("mark", Fmark
, Smark
, 0, 0, 0,
235 "Return this buffer's mark value as integer, or nil if no mark.\n\
236 If you are using this in an editing command, you are most likely making\n\
237 a mistake; see the documentation of `set-mark'.")
240 return Fmarker_position (current_buffer
->mark
);
242 #endif /* commented out code */
244 DEFUN ("mark-marker", Fmark_marker
, Smark_marker
, 0, 0, 0,
245 "Return this buffer's mark, as a marker object.\n\
246 Watch out! Moving this marker changes the mark position.\n\
247 If you set the marker not to point anywhere, the buffer will have no mark.")
250 return current_buffer
->mark
;
253 #if 0 /* this is now in lisp code */
254 DEFUN ("set-mark", Fset_mark
, Sset_mark
, 1, 1, 0,
255 "Set this buffer's mark to POS. Don't use this function!\n\
256 That is to say, don't use this function unless you want\n\
257 the user to see that the mark has moved, and you want the previous\n\
258 mark position to be lost.\n\
260 Normally, when a new mark is set, the old one should go on the stack.\n\
261 This is why most applications should use push-mark, not set-mark.\n\
263 Novice programmers often try to use the mark for the wrong purposes.\n\
264 The mark saves a location for the user's convenience.\n\
265 Most editing commands should not alter the mark.\n\
266 To remember a location for internal use in the Lisp program,\n\
267 store it in a Lisp variable. Example:\n\
269 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
275 current_buffer
->mark
= Qnil
;
278 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
280 if (NILP (current_buffer
->mark
))
281 current_buffer
->mark
= Fmake_marker ();
283 Fset_marker (current_buffer
->mark
, pos
, Qnil
);
286 #endif /* commented-out code */
289 save_excursion_save ()
291 register int visible
= (XBUFFER (XWINDOW (selected_window
)->buffer
)
294 return Fcons (Fpoint_marker (),
295 Fcons (Fcopy_marker (current_buffer
->mark
),
296 Fcons (visible
? Qt
: Qnil
,
297 current_buffer
->mark_active
)));
301 save_excursion_restore (info
)
302 register Lisp_Object info
;
304 register Lisp_Object tem
, tem1
, omark
, nmark
;
306 tem
= Fmarker_buffer (Fcar (info
));
307 /* If buffer being returned to is now deleted, avoid error */
308 /* Otherwise could get error here while unwinding to top level
310 /* In that case, Fmarker_buffer returns nil now. */
316 unchain_marker (tem
);
317 tem
= Fcar (Fcdr (info
));
318 omark
= Fmarker_position (current_buffer
->mark
);
319 Fset_marker (current_buffer
->mark
, tem
, Fcurrent_buffer ());
320 nmark
= Fmarker_position (tem
);
321 unchain_marker (tem
);
322 tem
= Fcdr (Fcdr (info
));
323 #if 0 /* We used to make the current buffer visible in the selected window
324 if that was true previously. That avoids some anomalies.
325 But it creates others, and it wasn't documented, and it is simpler
326 and cleaner never to alter the window/buffer connections. */
329 && current_buffer
!= XBUFFER (XWINDOW (selected_window
)->buffer
))
330 Fswitch_to_buffer (Fcurrent_buffer (), Qnil
);
333 tem1
= current_buffer
->mark_active
;
334 current_buffer
->mark_active
= Fcdr (tem
);
335 if (!NILP (Vrun_hooks
))
337 /* If mark is active now, and either was not active
338 or was at a different place, run the activate hook. */
339 if (! NILP (current_buffer
->mark_active
))
341 if (! EQ (omark
, nmark
))
342 call1 (Vrun_hooks
, intern ("activate-mark-hook"));
344 /* If mark has ceased to be active, run deactivate hook. */
345 else if (! NILP (tem1
))
346 call1 (Vrun_hooks
, intern ("deactivate-mark-hook"));
351 DEFUN ("save-excursion", Fsave_excursion
, Ssave_excursion
, 0, UNEVALLED
, 0,
352 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
353 Executes BODY just like `progn'.\n\
354 The values of point, mark and the current buffer are restored\n\
355 even in case of abnormal exit (throw or error).\n\
356 The state of activation of the mark is also restored.")
360 register Lisp_Object val
;
361 int count
= specpdl_ptr
- specpdl
;
363 record_unwind_protect (save_excursion_restore
, save_excursion_save ());
366 return unbind_to (count
, val
);
369 DEFUN ("buffer-size", Fbufsize
, Sbufsize
, 0, 0, 0,
370 "Return the number of characters in the current buffer.")
374 XSETFASTINT (temp
, Z
- BEG
);
378 DEFUN ("point-min", Fpoint_min
, Spoint_min
, 0, 0, 0,
379 "Return the minimum permissible value of point in the current buffer.\n\
380 This is 1, unless narrowing (a buffer restriction) is in effect.")
384 XSETFASTINT (temp
, BEGV
);
388 DEFUN ("point-min-marker", Fpoint_min_marker
, Spoint_min_marker
, 0, 0, 0,
389 "Return a marker to the minimum permissible value of point in this buffer.\n\
390 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
393 return buildmark (BEGV
);
396 DEFUN ("point-max", Fpoint_max
, Spoint_max
, 0, 0, 0,
397 "Return the maximum permissible value of point in the current buffer.\n\
398 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
399 is in effect, in which case it is less.")
403 XSETFASTINT (temp
, ZV
);
407 DEFUN ("point-max-marker", Fpoint_max_marker
, Spoint_max_marker
, 0, 0, 0,
408 "Return a marker to the maximum permissible value of point in this buffer.\n\
409 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
410 is in effect, in which case it is less.")
413 return buildmark (ZV
);
416 DEFUN ("following-char", Ffollowing_char
, Sfollowing_char
, 0, 0, 0,
417 "Return the character following point, as a number.\n\
418 At the end of the buffer or accessible region, return 0.")
423 XSETFASTINT (temp
, 0);
425 XSETFASTINT (temp
, FETCH_CHAR (point
));
429 DEFUN ("preceding-char", Fprevious_char
, Sprevious_char
, 0, 0, 0,
430 "Return the character preceding point, as a number.\n\
431 At the beginning of the buffer or accessible region, return 0.")
436 XSETFASTINT (temp
, 0);
438 XSETFASTINT (temp
, FETCH_CHAR (point
- 1));
442 DEFUN ("bobp", Fbobp
, Sbobp
, 0, 0, 0,
443 "Return T if point is at the beginning of the buffer.\n\
444 If the buffer is narrowed, this means the beginning of the narrowed part.")
452 DEFUN ("eobp", Feobp
, Seobp
, 0, 0, 0,
453 "Return T if point is at the end of the buffer.\n\
454 If the buffer is narrowed, this means the end of the narrowed part.")
462 DEFUN ("bolp", Fbolp
, Sbolp
, 0, 0, 0,
463 "Return T if point is at the beginning of a line.")
466 if (point
== BEGV
|| FETCH_CHAR (point
- 1) == '\n')
471 DEFUN ("eolp", Feolp
, Seolp
, 0, 0, 0,
472 "Return T if point is at the end of a line.\n\
473 `End of a line' includes point being at the end of the buffer.")
476 if (point
== ZV
|| FETCH_CHAR (point
) == '\n')
481 DEFUN ("char-after", Fchar_after
, Schar_after
, 1, 1, 0,
482 "Return character in current buffer at position POS.\n\
483 POS is an integer or a buffer pointer.\n\
484 If POS is out of range, the value is nil.")
488 register Lisp_Object val
;
491 CHECK_NUMBER_COERCE_MARKER (pos
, 0);
494 if (n
< BEGV
|| n
>= ZV
) return Qnil
;
496 XSETFASTINT (val
, FETCH_CHAR (n
));
500 DEFUN ("user-login-name", Fuser_login_name
, Suser_login_name
, 0, 1, 0,
501 "Return the name under which the user logged in, as a string.\n\
502 This is based on the effective uid, not the real uid.\n\
503 Also, if the environment variable LOGNAME or USER is set,\n\
504 that determines the value of this function.\n\n\
505 If optional argument UID is an integer, return the login name of the user\n\
506 with that uid, or nil if there is no such user.")
512 /* Set up the user name info if we didn't do it before.
513 (That can happen if Emacs is dumpable
514 but you decide to run `temacs -l loadup' and not dump. */
515 if (INTEGERP (Vuser_name
))
521 CHECK_NUMBER (uid
, 0);
522 pw
= (struct passwd
*) getpwuid (XINT (uid
));
523 return (pw
? build_string (pw
->pw_name
) : Qnil
);
526 DEFUN ("user-real-login-name", Fuser_real_login_name
, Suser_real_login_name
,
528 "Return the name of the user's real uid, as a string.\n\
529 This ignores the environment variables LOGNAME and USER, so it differs from\n\
530 `user-login-name' when running under `su'.")
533 /* Set up the user name info if we didn't do it before.
534 (That can happen if Emacs is dumpable
535 but you decide to run `temacs -l loadup' and not dump. */
536 if (INTEGERP (Vuser_name
))
538 return Vuser_real_name
;
541 DEFUN ("user-uid", Fuser_uid
, Suser_uid
, 0, 0, 0,
542 "Return the effective uid of Emacs, as an integer.")
545 return make_number (geteuid ());
548 DEFUN ("user-real-uid", Fuser_real_uid
, Suser_real_uid
, 0, 0, 0,
549 "Return the real uid of Emacs, as an integer.")
552 return make_number (getuid ());
555 DEFUN ("user-full-name", Fuser_full_name
, Suser_full_name
, 0, 0, 0,
556 "Return the full name of the user logged in, as a string.")
559 return Vuser_full_name
;
562 DEFUN ("system-name", Fsystem_name
, Ssystem_name
, 0, 0, 0,
563 "Return the name of the machine you are running on, as a string.")
569 /* For the benefit of callers who don't want to include lisp.h */
573 return (char *) XSTRING (Vsystem_name
)->data
;
576 DEFUN ("emacs-pid", Femacs_pid
, Semacs_pid
, 0, 0, 0,
577 "Return the process ID of Emacs, as an integer.")
580 return make_number (getpid ());
583 DEFUN ("current-time", Fcurrent_time
, Scurrent_time
, 0, 0, 0,
584 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
585 The time is returned as a list of three integers. The first has the\n\
586 most significant 16 bits of the seconds, while the second has the\n\
587 least significant 16 bits. The third integer gives the microsecond\n\
590 The microsecond count is zero on systems that do not provide\n\
591 resolution finer than a second.")
595 Lisp_Object result
[3];
598 XSETINT (result
[0], (EMACS_SECS (t
) >> 16) & 0xffff);
599 XSETINT (result
[1], (EMACS_SECS (t
) >> 0) & 0xffff);
600 XSETINT (result
[2], EMACS_USECS (t
));
602 return Flist (3, result
);
607 lisp_time_argument (specified_time
, result
)
608 Lisp_Object specified_time
;
611 if (NILP (specified_time
))
612 return time (result
) != -1;
615 Lisp_Object high
, low
;
616 high
= Fcar (specified_time
);
617 CHECK_NUMBER (high
, 0);
618 low
= Fcdr (specified_time
);
621 CHECK_NUMBER (low
, 0);
622 *result
= (XINT (high
) << 16) + (XINT (low
) & 0xffff);
623 return *result
>> 16 == XINT (high
);
627 DEFUN ("format-time-string", Fformat_time_string
, Sformat_time_string
, 2, 2, 0,
628 "Use FORMAT-STRING to format the time TIME.\n\
629 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from\n\
630 `current-time' and `file-attributes'.\n\
631 FORMAT-STRING may contain %-sequences to substitute parts of the time.\n\
632 %a is replaced by the abbreviated name of the day of week.\n\
633 %A is replaced by the full name of the day of week.\n\
634 %b is replaced by the abbreviated name of the month.\n\
635 %B is replaced by the full name of the month.\n\
636 %c is a synonym for \"%x %X\".\n\
637 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.\n\
638 %d is replaced by the day of month, zero-padded.\n\
639 %D is a synonym for \"%m/%d/%y\".\n\
640 %e is replaced by the day of month, blank-padded.\n\
641 %h is a synonym for \"%b\".\n\
642 %H is replaced by the hour (00-23).\n\
643 %I is replaced by the hour (00-12).\n\
644 %j is replaced by the day of the year (001-366).\n\
645 %k is replaced by the hour (0-23), blank padded.\n\
646 %l is replaced by the hour (1-12), blank padded.\n\
647 %m is replaced by the month (01-12).\n\
648 %M is replaced by the minut (00-59).\n\
649 %n is a synonym for \"\\n\".\n\
650 %p is replaced by AM or PM, as appropriate.\n\
651 %r is a synonym for \"%I:%M:%S %p\".\n\
652 %R is a synonym for \"%H:%M\".\n\
653 %S is replaced by the seconds (00-60).\n\
654 %t is a synonym for \"\\t\".\n\
655 %T is a synonym for \"%H:%M:%S\".\n\
656 %U is replaced by the week of the year (01-52), first day of week is Sunday.\n\
657 %w is replaced by the day of week (0-6), Sunday is day 0.\n\
658 %W is replaced by the week of the year (01-52), first day of week is Monday.\n\
659 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.\n\
660 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.\n\
661 %y is replaced by the year without century (00-99).\n\
662 %Y is replaced by the year with century.\n\
663 %Z is replaced by the time zone abbreviation.\n\
665 The number of options reflects the strftime(3) function.")
666 (format_string
, time
)
667 Lisp_Object format_string
, time
;
672 CHECK_STRING (format_string
, 1);
674 if (! lisp_time_argument (time
, &value
))
675 error ("Invalid time specification");
677 /* This is probably enough. */
678 size
= XSTRING (format_string
)->size
* 6 + 50;
682 char *buf
= (char *) alloca (size
);
683 if (strftime (buf
, size
, XSTRING (format_string
)->data
,
685 return build_string (buf
);
686 /* If buffer was too small, make it bigger. */
691 DEFUN ("decode-time", Fdecode_time
, Sdecode_time
, 0, 1, 0,
692 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
693 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
694 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
695 to use the current time. The list has the following nine members:\n\
696 SEC is an integer between 0 and 59. MINUTE is an integer between 0 and 59.\n\
697 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
698 MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
699 four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
700 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
701 ZONE is an integer indicating the number of seconds east of Greenwich.\n\
702 (Note that Common Lisp has different meanings for DOW and ZONE.)")
704 Lisp_Object specified_time
;
708 struct tm
*decoded_time
;
709 Lisp_Object list_args
[9];
711 if (! lisp_time_argument (specified_time
, &time_spec
))
712 error ("Invalid time specification");
714 decoded_time
= localtime (&time_spec
);
715 XSETFASTINT (list_args
[0], decoded_time
->tm_sec
);
716 XSETFASTINT (list_args
[1], decoded_time
->tm_min
);
717 XSETFASTINT (list_args
[2], decoded_time
->tm_hour
);
718 XSETFASTINT (list_args
[3], decoded_time
->tm_mday
);
719 XSETFASTINT (list_args
[4], decoded_time
->tm_mon
+ 1);
720 XSETFASTINT (list_args
[5], decoded_time
->tm_year
+ 1900);
721 XSETFASTINT (list_args
[6], decoded_time
->tm_wday
);
722 list_args
[7] = (decoded_time
->tm_isdst
)? Qt
: Qnil
;
724 /* Make a copy, in case gmtime modifies the struct. */
725 save_tm
= *decoded_time
;
726 decoded_time
= gmtime (&time_spec
);
727 if (decoded_time
== 0)
730 XSETINT (list_args
[8], difftm (&save_tm
, decoded_time
));
731 return Flist (9, list_args
);
734 DEFUN ("current-time-string", Fcurrent_time_string
, Scurrent_time_string
, 0, 1, 0,
735 "Return the current time, as a human-readable string.\n\
736 Programs can use this function to decode a time,\n\
737 since the number of columns in each field is fixed.\n\
738 The format is `Sun Sep 16 01:03:52 1973'.\n\
739 If an argument is given, it specifies a time to format\n\
740 instead of the current time. The argument should have the form:\n\
743 (HIGH LOW . IGNORED).\n\
744 Thus, you can use times obtained from `current-time'\n\
745 and from `file-attributes'.")
747 Lisp_Object specified_time
;
753 if (! lisp_time_argument (specified_time
, &value
))
755 tem
= (char *) ctime (&value
);
757 strncpy (buf
, tem
, 24);
760 return build_string (buf
);
763 #define TM_YEAR_ORIGIN 1900
765 /* Yield A - B, measured in seconds. */
770 int ay
= a
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
771 int by
= b
->tm_year
+ (TM_YEAR_ORIGIN
- 1);
772 /* Some compilers can't handle this as a single return statement. */
774 /* difference in day of year */
775 a
->tm_yday
- b
->tm_yday
776 /* + intervening leap days */
777 + ((ay
>> 2) - (by
>> 2))
779 + ((ay
/100 >> 2) - (by
/100 >> 2))
780 /* + difference in years * 365 */
781 + (long)(ay
-by
) * 365
783 return (60*(60*(24*days
+ (a
->tm_hour
- b
->tm_hour
))
784 + (a
->tm_min
- b
->tm_min
))
785 + (a
->tm_sec
- b
->tm_sec
));
788 DEFUN ("current-time-zone", Fcurrent_time_zone
, Scurrent_time_zone
, 0, 1, 0,
789 "Return the offset and name for the local time zone.\n\
790 This returns a list of the form (OFFSET NAME).\n\
791 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
792 A negative value means west of Greenwich.\n\
793 NAME is a string giving the name of the time zone.\n\
794 If an argument is given, it specifies when the time zone offset is determined\n\
795 instead of using the current time. The argument should have the form:\n\
798 (HIGH LOW . IGNORED).\n\
799 Thus, you can use times obtained from `current-time'\n\
800 and from `file-attributes'.\n\
802 Some operating systems cannot provide all this information to Emacs;\n\
803 in this case, `current-time-zone' returns a list containing nil for\n\
804 the data it can't find.")
806 Lisp_Object specified_time
;
811 if (lisp_time_argument (specified_time
, &value
)
812 && (t
= gmtime (&value
)) != 0)
818 gmt
= *t
; /* Make a copy, in case localtime modifies *t. */
819 t
= localtime (&value
);
820 offset
= difftm (t
, &gmt
);
824 s
= (char *)t
->tm_zone
;
825 #else /* not HAVE_TM_ZONE */
827 if (t
->tm_isdst
== 0 || t
->tm_isdst
== 1)
828 s
= tzname
[t
->tm_isdst
];
830 #endif /* not HAVE_TM_ZONE */
833 /* No local time zone name is available; use "+-NNNN" instead. */
834 int am
= (offset
< 0 ? -offset
: offset
) / 60;
835 sprintf (buf
, "%c%02d%02d", (offset
< 0 ? '-' : '+'), am
/60, am
%60);
838 return Fcons (make_number (offset
), Fcons (build_string (s
), Qnil
));
841 return Fmake_list (2, Qnil
);
853 /* Callers passing one argument to Finsert need not gcpro the
854 argument "array", since the only element of the array will
855 not be used after calling insert or insert_from_string, so
856 we don't care if it gets trashed. */
858 DEFUN ("insert", Finsert
, Sinsert
, 0, MANY
, 0,
859 "Insert the arguments, either strings or characters, at point.\n\
860 Point moves forward so that it ends up after the inserted text.\n\
861 Any other markers at the point of insertion remain before the text.")
864 register Lisp_Object
*args
;
867 register Lisp_Object tem
;
870 for (argnum
= 0; argnum
< nargs
; argnum
++)
879 else if (STRINGP (tem
))
881 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 0);
885 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
893 DEFUN ("insert-and-inherit", Finsert_and_inherit
, Sinsert_and_inherit
,
895 "Insert the arguments at point, inheriting properties from adjoining text.\n\
896 Point moves forward so that it ends up after the inserted text.\n\
897 Any other markers at the point of insertion remain before the text.")
900 register Lisp_Object
*args
;
903 register Lisp_Object tem
;
906 for (argnum
= 0; argnum
< nargs
; argnum
++)
913 insert_and_inherit (str
, 1);
915 else if (STRINGP (tem
))
917 insert_from_string (tem
, 0, XSTRING (tem
)->size
, 1);
921 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
929 DEFUN ("insert-before-markers", Finsert_before_markers
, Sinsert_before_markers
, 0, MANY
, 0,
930 "Insert strings or characters at point, relocating markers after the text.\n\
931 Point moves forward so that it ends up after the inserted text.\n\
932 Any other markers at the point of insertion also end up after the text.")
935 register Lisp_Object
*args
;
938 register Lisp_Object tem
;
941 for (argnum
= 0; argnum
< nargs
; argnum
++)
948 insert_before_markers (str
, 1);
950 else if (STRINGP (tem
))
952 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 0);
956 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
964 DEFUN ("insert-before-markers-and-inherit",
965 Finsert_and_inherit_before_markers
, Sinsert_and_inherit_before_markers
,
967 "Insert text at point, relocating markers and inheriting properties.\n\
968 Point moves forward so that it ends up after the inserted text.\n\
969 Any other markers at the point of insertion also end up after the text.")
972 register Lisp_Object
*args
;
975 register Lisp_Object tem
;
978 for (argnum
= 0; argnum
< nargs
; argnum
++)
985 insert_before_markers_and_inherit (str
, 1);
987 else if (STRINGP (tem
))
989 insert_from_string_before_markers (tem
, 0, XSTRING (tem
)->size
, 1);
993 tem
= wrong_type_argument (Qchar_or_string_p
, tem
);
1001 DEFUN ("insert-char", Finsert_char
, Sinsert_char
, 2, 3, 0,
1002 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
1003 Point and all markers are affected as in the function `insert'.\n\
1004 Both arguments are required.\n\
1005 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1006 from adjoining text, if those properties are sticky.")
1007 (chr
, count
, inherit
)
1008 Lisp_Object chr
, count
, inherit
;
1010 register unsigned char *string
;
1011 register int strlen
;
1014 CHECK_NUMBER (chr
, 0);
1015 CHECK_NUMBER (count
, 1);
1020 strlen
= min (n
, 256);
1021 string
= (unsigned char *) alloca (strlen
);
1022 for (i
= 0; i
< strlen
; i
++)
1023 string
[i
] = XFASTINT (chr
);
1026 if (!NILP (inherit
))
1027 insert_and_inherit (string
, strlen
);
1029 insert (string
, strlen
);
1034 if (!NILP (inherit
))
1035 insert_and_inherit (string
, n
);
1043 /* Making strings from buffer contents. */
1045 /* Return a Lisp_String containing the text of the current buffer from
1046 START to END. If text properties are in use and the current buffer
1047 has properties in the range specified, the resulting string will also
1050 We don't want to use plain old make_string here, because it calls
1051 make_uninit_string, which can cause the buffer arena to be
1052 compacted. make_string has no way of knowing that the data has
1053 been moved, and thus copies the wrong data into the string. This
1054 doesn't effect most of the other users of make_string, so it should
1055 be left as is. But we should use this function when conjuring
1056 buffer substrings. */
1059 make_buffer_string (start
, end
)
1062 Lisp_Object result
, tem
, tem1
;
1064 if (start
< GPT
&& GPT
< end
)
1067 result
= make_uninit_string (end
- start
);
1068 bcopy (&FETCH_CHAR (start
), XSTRING (result
)->data
, end
- start
);
1070 tem
= Fnext_property_change (make_number (start
), Qnil
, make_number (end
));
1071 tem1
= Ftext_properties_at (make_number (start
), Qnil
);
1073 #ifdef USE_TEXT_PROPERTIES
1074 if (XINT (tem
) != end
|| !NILP (tem1
))
1075 copy_intervals_to_string (result
, current_buffer
, start
, end
- start
);
1081 DEFUN ("buffer-substring", Fbuffer_substring
, Sbuffer_substring
, 2, 2, 0,
1082 "Return the contents of part of the current buffer as a string.\n\
1083 The two arguments START and END are character positions;\n\
1084 they can be in either order.")
1088 register int beg
, end
;
1090 validate_region (&b
, &e
);
1094 return make_buffer_string (beg
, end
);
1097 DEFUN ("buffer-string", Fbuffer_string
, Sbuffer_string
, 0, 0, 0,
1098 "Return the contents of the current buffer as a string.")
1101 return make_buffer_string (BEGV
, ZV
);
1104 DEFUN ("insert-buffer-substring", Finsert_buffer_substring
, Sinsert_buffer_substring
,
1106 "Insert before point a substring of the contents of buffer BUFFER.\n\
1107 BUFFER may be a buffer or a buffer name.\n\
1108 Arguments START and END are character numbers specifying the substring.\n\
1109 They default to the beginning and the end of BUFFER.")
1111 Lisp_Object buf
, b
, e
;
1113 register int beg
, end
, temp
;
1114 register struct buffer
*bp
;
1117 buffer
= Fget_buffer (buf
);
1120 bp
= XBUFFER (buffer
);
1123 beg
= BUF_BEGV (bp
);
1126 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1133 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1138 temp
= beg
, beg
= end
, end
= temp
;
1140 if (!(BUF_BEGV (bp
) <= beg
&& end
<= BUF_ZV (bp
)))
1141 args_out_of_range (b
, e
);
1143 insert_from_buffer (bp
, beg
, end
- beg
, 0);
1147 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings
, Scompare_buffer_substrings
,
1149 "Compare two substrings of two buffers; return result as number.\n\
1150 the value is -N if first string is less after N-1 chars,\n\
1151 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1152 Each substring is represented as three arguments: BUFFER, START and END.\n\
1153 That makes six args in all, three for each substring.\n\n\
1154 The value of `case-fold-search' in the current buffer\n\
1155 determines whether case is significant or ignored.")
1156 (buffer1
, start1
, end1
, buffer2
, start2
, end2
)
1157 Lisp_Object buffer1
, start1
, end1
, buffer2
, start2
, end2
;
1159 register int begp1
, endp1
, begp2
, endp2
, temp
, len1
, len2
, length
, i
;
1160 register struct buffer
*bp1
, *bp2
;
1161 register unsigned char *trt
1162 = (!NILP (current_buffer
->case_fold_search
)
1163 ? XSTRING (current_buffer
->case_canon_table
)->data
: 0);
1165 /* Find the first buffer and its substring. */
1168 bp1
= current_buffer
;
1172 buf1
= Fget_buffer (buffer1
);
1175 bp1
= XBUFFER (buf1
);
1179 begp1
= BUF_BEGV (bp1
);
1182 CHECK_NUMBER_COERCE_MARKER (start1
, 1);
1183 begp1
= XINT (start1
);
1186 endp1
= BUF_ZV (bp1
);
1189 CHECK_NUMBER_COERCE_MARKER (end1
, 2);
1190 endp1
= XINT (end1
);
1194 temp
= begp1
, begp1
= endp1
, endp1
= temp
;
1196 if (!(BUF_BEGV (bp1
) <= begp1
1198 && endp1
<= BUF_ZV (bp1
)))
1199 args_out_of_range (start1
, end1
);
1201 /* Likewise for second substring. */
1204 bp2
= current_buffer
;
1208 buf2
= Fget_buffer (buffer2
);
1211 bp2
= XBUFFER (buffer2
);
1215 begp2
= BUF_BEGV (bp2
);
1218 CHECK_NUMBER_COERCE_MARKER (start2
, 4);
1219 begp2
= XINT (start2
);
1222 endp2
= BUF_ZV (bp2
);
1225 CHECK_NUMBER_COERCE_MARKER (end2
, 5);
1226 endp2
= XINT (end2
);
1230 temp
= begp2
, begp2
= endp2
, endp2
= temp
;
1232 if (!(BUF_BEGV (bp2
) <= begp2
1234 && endp2
<= BUF_ZV (bp2
)))
1235 args_out_of_range (start2
, end2
);
1237 len1
= endp1
- begp1
;
1238 len2
= endp2
- begp2
;
1243 for (i
= 0; i
< length
; i
++)
1245 int c1
= *BUF_CHAR_ADDRESS (bp1
, begp1
+ i
);
1246 int c2
= *BUF_CHAR_ADDRESS (bp2
, begp2
+ i
);
1253 return make_number (- 1 - i
);
1255 return make_number (i
+ 1);
1258 /* The strings match as far as they go.
1259 If one is shorter, that one is less. */
1261 return make_number (length
+ 1);
1262 else if (length
< len2
)
1263 return make_number (- length
- 1);
1265 /* Same length too => they are equal. */
1266 return make_number (0);
1269 DEFUN ("subst-char-in-region", Fsubst_char_in_region
,
1270 Ssubst_char_in_region
, 4, 5, 0,
1271 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1272 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1273 and don't mark the buffer as really changed.")
1274 (start
, end
, fromchar
, tochar
, noundo
)
1275 Lisp_Object start
, end
, fromchar
, tochar
, noundo
;
1277 register int pos
, stop
, look
;
1280 validate_region (&start
, &end
);
1281 CHECK_NUMBER (fromchar
, 2);
1282 CHECK_NUMBER (tochar
, 3);
1286 look
= XINT (fromchar
);
1290 if (FETCH_CHAR (pos
) == look
)
1294 modify_region (current_buffer
, XINT (start
), stop
);
1296 if (! NILP (noundo
))
1298 if (MODIFF
- 1 == SAVE_MODIFF
)
1300 if (MODIFF
- 1 == current_buffer
->auto_save_modified
)
1301 current_buffer
->auto_save_modified
++;
1308 record_change (pos
, 1);
1309 FETCH_CHAR (pos
) = XINT (tochar
);
1315 signal_after_change (XINT (start
),
1316 stop
- XINT (start
), stop
- XINT (start
));
1321 DEFUN ("translate-region", Ftranslate_region
, Stranslate_region
, 3, 3, 0,
1322 "From START to END, translate characters according to TABLE.\n\
1323 TABLE is a string; the Nth character in it is the mapping\n\
1324 for the character with code N. Returns the number of characters changed.")
1328 register Lisp_Object table
;
1330 register int pos
, stop
; /* Limits of the region. */
1331 register unsigned char *tt
; /* Trans table. */
1332 register int oc
; /* Old character. */
1333 register int nc
; /* New character. */
1334 int cnt
; /* Number of changes made. */
1335 Lisp_Object z
; /* Return. */
1336 int size
; /* Size of translate table. */
1338 validate_region (&start
, &end
);
1339 CHECK_STRING (table
, 2);
1341 size
= XSTRING (table
)->size
;
1342 tt
= XSTRING (table
)->data
;
1346 modify_region (current_buffer
, pos
, stop
);
1349 for (; pos
< stop
; ++pos
)
1351 oc
= FETCH_CHAR (pos
);
1357 record_change (pos
, 1);
1358 FETCH_CHAR (pos
) = nc
;
1359 signal_after_change (pos
, 1, 1);
1365 XSETFASTINT (z
, cnt
);
1369 DEFUN ("delete-region", Fdelete_region
, Sdelete_region
, 2, 2, "r",
1370 "Delete the text between point and mark.\n\
1371 When called from a program, expects two arguments,\n\
1372 positions (integers or markers) specifying the stretch to be deleted.")
1376 validate_region (&b
, &e
);
1377 del_range (XINT (b
), XINT (e
));
1381 DEFUN ("widen", Fwiden
, Swiden
, 0, 0, "",
1382 "Remove restrictions (narrowing) from current buffer.\n\
1383 This allows the buffer's full text to be seen and edited.")
1387 SET_BUF_ZV (current_buffer
, Z
);
1389 /* Changing the buffer bounds invalidates any recorded current column. */
1390 invalidate_current_column ();
1394 DEFUN ("narrow-to-region", Fnarrow_to_region
, Snarrow_to_region
, 2, 2, "r",
1395 "Restrict editing in this buffer to the current region.\n\
1396 The rest of the text becomes temporarily invisible and untouchable\n\
1397 but is not deleted; if you save the buffer in a file, the invisible\n\
1398 text is included in the file. \\[widen] makes all visible again.\n\
1399 See also `save-restriction'.\n\
1401 When calling from a program, pass two arguments; positions (integers\n\
1402 or markers) bounding the text that should remain visible.")
1404 register Lisp_Object b
, e
;
1406 CHECK_NUMBER_COERCE_MARKER (b
, 0);
1407 CHECK_NUMBER_COERCE_MARKER (e
, 1);
1409 if (XINT (b
) > XINT (e
))
1412 tem
= b
; b
= e
; e
= tem
;
1415 if (!(BEG
<= XINT (b
) && XINT (b
) <= XINT (e
) && XINT (e
) <= Z
))
1416 args_out_of_range (b
, e
);
1418 BEGV
= XFASTINT (b
);
1419 SET_BUF_ZV (current_buffer
, XFASTINT (e
));
1420 if (point
< XFASTINT (b
))
1421 SET_PT (XFASTINT (b
));
1422 if (point
> XFASTINT (e
))
1423 SET_PT (XFASTINT (e
));
1425 /* Changing the buffer bounds invalidates any recorded current column. */
1426 invalidate_current_column ();
1431 save_restriction_save ()
1433 register Lisp_Object bottom
, top
;
1434 /* Note: I tried using markers here, but it does not win
1435 because insertion at the end of the saved region
1436 does not advance mh and is considered "outside" the saved region. */
1437 XSETFASTINT (bottom
, BEGV
- BEG
);
1438 XSETFASTINT (top
, Z
- ZV
);
1440 return Fcons (Fcurrent_buffer (), Fcons (bottom
, top
));
1444 save_restriction_restore (data
)
1447 register struct buffer
*buf
;
1448 register int newhead
, newtail
;
1449 register Lisp_Object tem
;
1451 buf
= XBUFFER (XCONS (data
)->car
);
1453 data
= XCONS (data
)->cdr
;
1455 tem
= XCONS (data
)->car
;
1456 newhead
= XINT (tem
);
1457 tem
= XCONS (data
)->cdr
;
1458 newtail
= XINT (tem
);
1459 if (newhead
+ newtail
> BUF_Z (buf
) - BUF_BEG (buf
))
1464 BUF_BEGV (buf
) = BUF_BEG (buf
) + newhead
;
1465 SET_BUF_ZV (buf
, BUF_Z (buf
) - newtail
);
1468 /* If point is outside the new visible range, move it inside. */
1470 clip_to_bounds (BUF_BEGV (buf
), BUF_PT (buf
), BUF_ZV (buf
)));
1475 DEFUN ("save-restriction", Fsave_restriction
, Ssave_restriction
, 0, UNEVALLED
, 0,
1476 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1477 The buffer's restrictions make parts of the beginning and end invisible.\n\
1478 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1479 This special form, `save-restriction', saves the current buffer's restrictions\n\
1480 when it is entered, and restores them when it is exited.\n\
1481 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1482 The old restrictions settings are restored\n\
1483 even in case of abnormal exit (throw or error).\n\
1485 The value returned is the value of the last form in BODY.\n\
1487 `save-restriction' can get confused if, within the BODY, you widen\n\
1488 and then make changes outside the area within the saved restrictions.\n\
1490 Note: if you are using both `save-excursion' and `save-restriction',\n\
1491 use `save-excursion' outermost:\n\
1492 (save-excursion (save-restriction ...))")
1496 register Lisp_Object val
;
1497 int count
= specpdl_ptr
- specpdl
;
1499 record_unwind_protect (save_restriction_restore
, save_restriction_save ());
1500 val
= Fprogn (body
);
1501 return unbind_to (count
, val
);
1504 /* Buffer for the most recent text displayed by Fmessage. */
1505 static char *message_text
;
1507 /* Allocated length of that buffer. */
1508 static int message_length
;
1510 DEFUN ("message", Fmessage
, Smessage
, 1, MANY
, 0,
1511 "Print a one-line message at the bottom of the screen.\n\
1512 The first argument is a control string.\n\
1513 It may contain %s or %d or %c to print successive following arguments.\n\
1514 %s means print an argument as a string, %d means print as number in decimal,\n\
1515 %c means print a number as a single character.\n\
1516 The argument used by %s must be a string or a symbol;\n\
1517 the argument used by %d or %c must be a number.\n\
1518 If the first argument is nil, clear any existing message; let the\n\
1519 minibuffer contents show.")
1531 register Lisp_Object val
;
1532 val
= Fformat (nargs
, args
);
1533 /* Copy the data so that it won't move when we GC. */
1536 message_text
= (char *)xmalloc (80);
1537 message_length
= 80;
1539 if (XSTRING (val
)->size
> message_length
)
1541 message_length
= XSTRING (val
)->size
;
1542 message_text
= (char *)xrealloc (message_text
, message_length
);
1544 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1545 message2 (message_text
, XSTRING (val
)->size
);
1550 DEFUN ("message-box", Fmessage_box
, Smessage_box
, 1, MANY
, 0,
1551 "Display a message, in a dialog box if possible.\n\
1552 If a dialog box is not available, use the echo area.\n\
1553 The first argument is a control string.\n\
1554 It may contain %s or %d or %c to print successive following arguments.\n\
1555 %s means print an argument as a string, %d means print as number in decimal,\n\
1556 %c means print a number as a single character.\n\
1557 The argument used by %s must be a string or a symbol;\n\
1558 the argument used by %d or %c must be a number.\n\
1559 If the first argument is nil, clear any existing message; let the\n\
1560 minibuffer contents show.")
1572 register Lisp_Object val
;
1573 val
= Fformat (nargs
, args
);
1576 Lisp_Object pane
, menu
, obj
;
1577 struct gcpro gcpro1
;
1578 pane
= Fcons (Fcons (build_string ("OK"), Qt
), Qnil
);
1580 menu
= Fcons (val
, pane
);
1581 obj
= Fx_popup_dialog (Qt
, menu
);
1586 /* Copy the data so that it won't move when we GC. */
1589 message_text
= (char *)xmalloc (80);
1590 message_length
= 80;
1592 if (XSTRING (val
)->size
> message_length
)
1594 message_length
= XSTRING (val
)->size
;
1595 message_text
= (char *)xrealloc (message_text
, message_length
);
1597 bcopy (XSTRING (val
)->data
, message_text
, XSTRING (val
)->size
);
1598 message2 (message_text
, XSTRING (val
)->size
);
1604 extern Lisp_Object last_nonmenu_event
;
1606 DEFUN ("message-or-box", Fmessage_or_box
, Smessage_or_box
, 1, MANY
, 0,
1607 "Display a message in a dialog box or in the echo area.\n\
1608 If this command was invoked with the mouse, use a dialog box.\n\
1609 Otherwise, use the echo area.\n\
1611 The first argument is a control string.\n\
1612 It may contain %s or %d or %c to print successive following arguments.\n\
1613 %s means print an argument as a string, %d means print as number in decimal,\n\
1614 %c means print a number as a single character.\n\
1615 The argument used by %s must be a string or a symbol;\n\
1616 the argument used by %d or %c must be a number.\n\
1617 If the first argument is nil, clear any existing message; let the\n\
1618 minibuffer contents show.")
1624 if (NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
1625 return Fmessage_box (nargs
, args
);
1627 return Fmessage (nargs
, args
);
1630 DEFUN ("format", Fformat
, Sformat
, 1, MANY
, 0,
1631 "Format a string out of a control-string and arguments.\n\
1632 The first argument is a control string.\n\
1633 The other arguments are substituted into it to make the result, a string.\n\
1634 It may contain %-sequences meaning to substitute the next argument.\n\
1635 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1636 %d means print as number in decimal (%o octal, %x hex).\n\
1637 %c means print a number as a single character.\n\
1638 %S means print any object as an s-expression (using prin1).\n\
1639 The argument used for %d, %o, %x or %c must be a number.\n\
1640 Use %% to put a single % into the output.")
1643 register Lisp_Object
*args
;
1645 register int n
; /* The number of the next arg to substitute */
1646 register int total
= 5; /* An estimate of the final length */
1648 register unsigned char *format
, *end
;
1650 extern char *index ();
1651 /* It should not be necessary to GCPRO ARGS, because
1652 the caller in the interpreter should take care of that. */
1654 CHECK_STRING (args
[0], 0);
1655 format
= XSTRING (args
[0])->data
;
1656 end
= format
+ XSTRING (args
[0])->size
;
1659 while (format
!= end
)
1660 if (*format
++ == '%')
1664 /* Process a numeric arg and skip it. */
1665 minlen
= atoi (format
);
1670 while ((*format
>= '0' && *format
<= '9')
1671 || *format
== '-' || *format
== ' ' || *format
== '.')
1676 else if (++n
>= nargs
)
1677 error ("not enough arguments for format string");
1678 else if (*format
== 'S')
1680 /* For `S', prin1 the argument and then treat like a string. */
1681 register Lisp_Object tem
;
1682 tem
= Fprin1_to_string (args
[n
], Qnil
);
1686 else if (SYMBOLP (args
[n
]))
1688 XSETSTRING (args
[n
], XSYMBOL (args
[n
])->name
);
1691 else if (STRINGP (args
[n
]))
1694 if (*format
!= 's' && *format
!= 'S')
1695 error ("format specifier doesn't match argument type");
1696 total
+= XSTRING (args
[n
])->size
;
1698 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1699 else if (INTEGERP (args
[n
]) && *format
!= 's')
1701 #ifdef LISP_FLOAT_TYPE
1702 /* The following loop assumes the Lisp type indicates
1703 the proper way to pass the argument.
1704 So make sure we have a flonum if the argument should
1706 if (*format
== 'e' || *format
== 'f' || *format
== 'g')
1707 args
[n
] = Ffloat (args
[n
]);
1711 #ifdef LISP_FLOAT_TYPE
1712 else if (FLOATP (args
[n
]) && *format
!= 's')
1714 if (! (*format
== 'e' || *format
== 'f' || *format
== 'g'))
1715 args
[n
] = Ftruncate (args
[n
]);
1721 /* Anything but a string, convert to a string using princ. */
1722 register Lisp_Object tem
;
1723 tem
= Fprin1_to_string (args
[n
], Qt
);
1730 register int nstrings
= n
+ 1;
1732 /* Allocate twice as many strings as we have %-escapes; floats occupy
1733 two slots, and we're not sure how many of those we have. */
1734 register unsigned char **strings
1735 = (unsigned char **) alloca (2 * nstrings
* sizeof (unsigned char *));
1739 for (n
= 0; n
< nstrings
; n
++)
1742 strings
[i
++] = (unsigned char *) "";
1743 else if (INTEGERP (args
[n
]))
1744 /* We checked above that the corresponding format effector
1745 isn't %s, which would cause MPV. */
1746 strings
[i
++] = (unsigned char *) XINT (args
[n
]);
1747 #ifdef LISP_FLOAT_TYPE
1748 else if (FLOATP (args
[n
]))
1750 union { double d
; int half
[2]; } u
;
1752 u
.d
= XFLOAT (args
[n
])->data
;
1753 strings
[i
++] = (unsigned char *) u
.half
[0];
1754 strings
[i
++] = (unsigned char *) u
.half
[1];
1758 strings
[i
++] = XSTRING (args
[n
])->data
;
1761 /* Format it in bigger and bigger buf's until it all fits. */
1764 buf
= (char *) alloca (total
+ 1);
1767 length
= doprnt (buf
, total
+ 1, strings
[0], end
, i
-1, strings
+ 1);
1768 if (buf
[total
- 1] == 0)
1776 return make_string (buf
, length
);
1782 format1 (string1
, arg0
, arg1
, arg2
, arg3
, arg4
)
1783 EMACS_INT arg0
, arg1
, arg2
, arg3
, arg4
;
1797 doprnt (buf
, sizeof buf
, string1
, 0, 5, args
);
1799 doprnt (buf
, sizeof buf
, string1
, 0, 5, &string1
+ 1);
1801 return build_string (buf
);
1804 DEFUN ("char-equal", Fchar_equal
, Schar_equal
, 2, 2, 0,
1805 "Return t if two characters match, optionally ignoring case.\n\
1806 Both arguments must be characters (i.e. integers).\n\
1807 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1809 register Lisp_Object c1
, c2
;
1811 unsigned char *downcase
= DOWNCASE_TABLE
;
1812 CHECK_NUMBER (c1
, 0);
1813 CHECK_NUMBER (c2
, 1);
1815 if (!NILP (current_buffer
->case_fold_search
)
1816 ? (downcase
[0xff & XFASTINT (c1
)] == downcase
[0xff & XFASTINT (c2
)]
1817 && (XFASTINT (c1
) & ~0xff) == (XFASTINT (c2
) & ~0xff))
1818 : XINT (c1
) == XINT (c2
))
1823 /* Transpose the markers in two regions of the current buffer, and
1824 adjust the ones between them if necessary (i.e.: if the regions
1827 Traverses the entire marker list of the buffer to do so, adding an
1828 appropriate amount to some, subtracting from some, and leaving the
1829 rest untouched. Most of this is copied from adjust_markers in insdel.c.
1831 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
1834 transpose_markers (start1
, end1
, start2
, end2
)
1835 register int start1
, end1
, start2
, end2
;
1837 register int amt1
, amt2
, diff
, mpos
;
1838 register Lisp_Object marker
;
1840 /* Update point as if it were a marker. */
1844 TEMP_SET_PT (PT
+ (end2
- end1
));
1845 else if (PT
< start2
)
1846 TEMP_SET_PT (PT
+ (end2
- start2
) - (end1
- start1
));
1848 TEMP_SET_PT (PT
- (start2
- start1
));
1850 /* We used to adjust the endpoints here to account for the gap, but that
1851 isn't good enough. Even if we assume the caller has tried to move the
1852 gap out of our way, it might still be at start1 exactly, for example;
1853 and that places it `inside' the interval, for our purposes. The amount
1854 of adjustment is nontrivial if there's a `denormalized' marker whose
1855 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
1856 the dirty work to Fmarker_position, below. */
1858 /* The difference between the region's lengths */
1859 diff
= (end2
- start2
) - (end1
- start1
);
1861 /* For shifting each marker in a region by the length of the other
1862 * region plus the distance between the regions.
1864 amt1
= (end2
- start2
) + (start2
- end1
);
1865 amt2
= (end1
- start1
) + (start2
- end1
);
1867 for (marker
= BUF_MARKERS (current_buffer
); !NILP (marker
);
1868 marker
= XMARKER (marker
)->chain
)
1870 mpos
= Fmarker_position (marker
);
1871 if (mpos
>= start1
&& mpos
< end2
)
1875 else if (mpos
< start2
)
1879 if (mpos
> GPT
) mpos
+= GAP_SIZE
;
1880 XMARKER (marker
)->bufpos
= mpos
;
1885 DEFUN ("transpose-regions", Ftranspose_regions
, Stranspose_regions
, 4, 5, 0,
1886 "Transpose region START1 to END1 with START2 to END2.\n\
1887 The regions may not be overlapping, because the size of the buffer is\n\
1888 never changed in a transposition.\n\
1890 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
1891 any markers that happen to be located in the regions.\n\
1893 Transposing beyond buffer boundaries is an error.")
1894 (startr1
, endr1
, startr2
, endr2
, leave_markers
)
1895 Lisp_Object startr1
, endr1
, startr2
, endr2
, leave_markers
;
1897 register int start1
, end1
, start2
, end2
,
1898 gap
, len1
, len_mid
, len2
;
1899 unsigned char *start1_addr
, *start2_addr
, *temp
;
1901 #ifdef USE_TEXT_PROPERTIES
1902 INTERVAL cur_intv
, tmp_interval1
, tmp_interval_mid
, tmp_interval2
;
1903 cur_intv
= BUF_INTERVALS (current_buffer
);
1904 #endif /* USE_TEXT_PROPERTIES */
1906 validate_region (&startr1
, &endr1
);
1907 validate_region (&startr2
, &endr2
);
1909 start1
= XFASTINT (startr1
);
1910 end1
= XFASTINT (endr1
);
1911 start2
= XFASTINT (startr2
);
1912 end2
= XFASTINT (endr2
);
1915 /* Swap the regions if they're reversed. */
1918 register int glumph
= start1
;
1926 len1
= end1
- start1
;
1927 len2
= end2
- start2
;
1930 error ("transposed regions not properly ordered");
1931 else if (start1
== end1
|| start2
== end2
)
1932 error ("transposed region may not be of length 0");
1934 /* The possibilities are:
1935 1. Adjacent (contiguous) regions, or separate but equal regions
1936 (no, really equal, in this case!), or
1937 2. Separate regions of unequal size.
1939 The worst case is usually No. 2. It means that (aside from
1940 potential need for getting the gap out of the way), there also
1941 needs to be a shifting of the text between the two regions. So
1942 if they are spread far apart, we are that much slower... sigh. */
1944 /* It must be pointed out that the really studly thing to do would
1945 be not to move the gap at all, but to leave it in place and work
1946 around it if necessary. This would be extremely efficient,
1947 especially considering that people are likely to do
1948 transpositions near where they are working interactively, which
1949 is exactly where the gap would be found. However, such code
1950 would be much harder to write and to read. So, if you are
1951 reading this comment and are feeling squirrely, by all means have
1952 a go! I just didn't feel like doing it, so I will simply move
1953 the gap the minimum distance to get it out of the way, and then
1954 deal with an unbroken array. */
1956 /* Make sure the gap won't interfere, by moving it out of the text
1957 we will operate on. */
1958 if (start1
< gap
&& gap
< end2
)
1960 if (gap
- start1
< end2
- gap
)
1966 /* Hmmm... how about checking to see if the gap is large
1967 enough to use as the temporary storage? That would avoid an
1968 allocation... interesting. Later, don't fool with it now. */
1970 /* Working without memmove, for portability (sigh), so must be
1971 careful of overlapping subsections of the array... */
1973 if (end1
== start2
) /* adjacent regions */
1975 modify_region (current_buffer
, start1
, end2
);
1976 record_change (start1
, len1
+ len2
);
1978 #ifdef USE_TEXT_PROPERTIES
1979 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
1980 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
1981 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
1982 #endif /* USE_TEXT_PROPERTIES */
1984 /* First region smaller than second. */
1987 /* We use alloca only if it is small,
1988 because we want to avoid stack overflow. */
1990 temp
= (unsigned char *) xmalloc (len2
);
1992 temp
= (unsigned char *) alloca (len2
);
1994 /* Don't precompute these addresses. We have to compute them
1995 at the last minute, because the relocating allocator might
1996 have moved the buffer around during the xmalloc. */
1997 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
1998 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2000 bcopy (start2_addr
, temp
, len2
);
2001 bcopy (start1_addr
, start1_addr
+ len2
, len1
);
2002 bcopy (temp
, start1_addr
, len2
);
2007 /* First region not smaller than second. */
2010 temp
= (unsigned char *) xmalloc (len1
);
2012 temp
= (unsigned char *) alloca (len1
);
2013 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2014 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2015 bcopy (start1_addr
, temp
, len1
);
2016 bcopy (start2_addr
, start1_addr
, len2
);
2017 bcopy (temp
, start1_addr
+ len2
, len1
);
2021 #ifdef USE_TEXT_PROPERTIES
2022 graft_intervals_into_buffer (tmp_interval1
, start1
+ len2
,
2023 len1
, current_buffer
, 0);
2024 graft_intervals_into_buffer (tmp_interval2
, start1
,
2025 len2
, current_buffer
, 0);
2026 #endif /* USE_TEXT_PROPERTIES */
2028 /* Non-adjacent regions, because end1 != start2, bleagh... */
2032 /* Regions are same size, though, how nice. */
2034 modify_region (current_buffer
, start1
, end1
);
2035 modify_region (current_buffer
, start2
, end2
);
2036 record_change (start1
, len1
);
2037 record_change (start2
, len2
);
2038 #ifdef USE_TEXT_PROPERTIES
2039 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2040 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2041 Fset_text_properties (start1
, end1
, Qnil
, Qnil
);
2042 Fset_text_properties (start2
, end2
, Qnil
, Qnil
);
2043 #endif /* USE_TEXT_PROPERTIES */
2046 temp
= (unsigned char *) xmalloc (len1
);
2048 temp
= (unsigned char *) alloca (len1
);
2049 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2050 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2051 bcopy (start1_addr
, temp
, len1
);
2052 bcopy (start2_addr
, start1_addr
, len2
);
2053 bcopy (temp
, start2_addr
, len1
);
2056 #ifdef USE_TEXT_PROPERTIES
2057 graft_intervals_into_buffer (tmp_interval1
, start2
,
2058 len1
, current_buffer
, 0);
2059 graft_intervals_into_buffer (tmp_interval2
, start1
,
2060 len2
, current_buffer
, 0);
2061 #endif /* USE_TEXT_PROPERTIES */
2064 else if (len1
< len2
) /* Second region larger than first */
2065 /* Non-adjacent & unequal size, area between must also be shifted. */
2067 len_mid
= start2
- end1
;
2068 modify_region (current_buffer
, start1
, end2
);
2069 record_change (start1
, (end2
- start1
));
2070 #ifdef USE_TEXT_PROPERTIES
2071 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2072 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2073 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2074 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2075 #endif /* USE_TEXT_PROPERTIES */
2077 /* holds region 2 */
2079 temp
= (unsigned char *) xmalloc (len2
);
2081 temp
= (unsigned char *) alloca (len2
);
2082 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2083 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2084 bcopy (start2_addr
, temp
, len2
);
2085 bcopy (start1_addr
, start1_addr
+ len_mid
+ len2
, len1
);
2086 safe_bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2087 bcopy (temp
, start1_addr
, len2
);
2090 #ifdef USE_TEXT_PROPERTIES
2091 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2092 len1
, current_buffer
, 0);
2093 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2094 len_mid
, current_buffer
, 0);
2095 graft_intervals_into_buffer (tmp_interval2
, start1
,
2096 len2
, current_buffer
, 0);
2097 #endif /* USE_TEXT_PROPERTIES */
2100 /* Second region smaller than first. */
2102 len_mid
= start2
- end1
;
2103 record_change (start1
, (end2
- start1
));
2104 modify_region (current_buffer
, start1
, end2
);
2106 #ifdef USE_TEXT_PROPERTIES
2107 tmp_interval1
= copy_intervals (cur_intv
, start1
, len1
);
2108 tmp_interval_mid
= copy_intervals (cur_intv
, end1
, len_mid
);
2109 tmp_interval2
= copy_intervals (cur_intv
, start2
, len2
);
2110 Fset_text_properties (start1
, end2
, Qnil
, Qnil
);
2111 #endif /* USE_TEXT_PROPERTIES */
2113 /* holds region 1 */
2115 temp
= (unsigned char *) xmalloc (len1
);
2117 temp
= (unsigned char *) alloca (len1
);
2118 start1_addr
= BUF_CHAR_ADDRESS (current_buffer
, start1
);
2119 start2_addr
= BUF_CHAR_ADDRESS (current_buffer
, start2
);
2120 bcopy (start1_addr
, temp
, len1
);
2121 bcopy (start2_addr
, start1_addr
, len2
);
2122 bcopy (start1_addr
+ len1
, start1_addr
+ len2
, len_mid
);
2123 bcopy (temp
, start1_addr
+ len2
+ len_mid
, len1
);
2126 #ifdef USE_TEXT_PROPERTIES
2127 graft_intervals_into_buffer (tmp_interval1
, end2
- len1
,
2128 len1
, current_buffer
, 0);
2129 graft_intervals_into_buffer (tmp_interval_mid
, start1
+ len2
,
2130 len_mid
, current_buffer
, 0);
2131 graft_intervals_into_buffer (tmp_interval2
, start1
,
2132 len2
, current_buffer
, 0);
2133 #endif /* USE_TEXT_PROPERTIES */
2137 /* todo: this will be slow, because for every transposition, we
2138 traverse the whole friggin marker list. Possible solutions:
2139 somehow get a list of *all* the markers across multiple
2140 transpositions and do it all in one swell phoop. Or maybe modify
2141 Emacs' marker code to keep an ordered list or tree. This might
2142 be nicer, and more beneficial in the long run, but would be a
2143 bunch of work. Plus the way they're arranged now is nice. */
2144 if (NILP (leave_markers
))
2146 transpose_markers (start1
, end1
, start2
, end2
);
2147 fix_overlays_in_range (start1
, end2
);
2157 DEFVAR_LISP ("system-name", &Vsystem_name
,
2158 "The name of the machine Emacs is running on.");
2160 DEFVAR_LISP ("user-full-name", &Vuser_full_name
,
2161 "The full name of the user logged in.");
2163 DEFVAR_LISP ("user-name", &Vuser_name
,
2164 "The user's name, taken from environment variables if possible.");
2166 DEFVAR_LISP ("user-real-name", &Vuser_real_name
,
2167 "The user's name, based upon the real uid only.");
2169 defsubr (&Schar_equal
);
2170 defsubr (&Sgoto_char
);
2171 defsubr (&Sstring_to_char
);
2172 defsubr (&Schar_to_string
);
2173 defsubr (&Sbuffer_substring
);
2174 defsubr (&Sbuffer_string
);
2176 defsubr (&Spoint_marker
);
2177 defsubr (&Smark_marker
);
2179 defsubr (&Sregion_beginning
);
2180 defsubr (&Sregion_end
);
2181 /* defsubr (&Smark); */
2182 /* defsubr (&Sset_mark); */
2183 defsubr (&Ssave_excursion
);
2185 defsubr (&Sbufsize
);
2186 defsubr (&Spoint_max
);
2187 defsubr (&Spoint_min
);
2188 defsubr (&Spoint_min_marker
);
2189 defsubr (&Spoint_max_marker
);
2195 defsubr (&Sfollowing_char
);
2196 defsubr (&Sprevious_char
);
2197 defsubr (&Schar_after
);
2199 defsubr (&Sinsert_before_markers
);
2200 defsubr (&Sinsert_and_inherit
);
2201 defsubr (&Sinsert_and_inherit_before_markers
);
2202 defsubr (&Sinsert_char
);
2204 defsubr (&Suser_login_name
);
2205 defsubr (&Suser_real_login_name
);
2206 defsubr (&Suser_uid
);
2207 defsubr (&Suser_real_uid
);
2208 defsubr (&Suser_full_name
);
2209 defsubr (&Semacs_pid
);
2210 defsubr (&Scurrent_time
);
2211 defsubr (&Sformat_time_string
);
2212 defsubr (&Sdecode_time
);
2213 defsubr (&Scurrent_time_string
);
2214 defsubr (&Scurrent_time_zone
);
2215 defsubr (&Ssystem_name
);
2216 defsubr (&Smessage
);
2217 defsubr (&Smessage_box
);
2218 defsubr (&Smessage_or_box
);
2221 defsubr (&Sinsert_buffer_substring
);
2222 defsubr (&Scompare_buffer_substrings
);
2223 defsubr (&Ssubst_char_in_region
);
2224 defsubr (&Stranslate_region
);
2225 defsubr (&Sdelete_region
);
2227 defsubr (&Snarrow_to_region
);
2228 defsubr (&Ssave_restriction
);
2229 defsubr (&Stranspose_regions
);