(REL_ALLOC): #undef deleted.
[emacs.git] / src / editfns.c
blob73166f9d9d501056bb43f74c24f8f228bedb1028
1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985,86,87,89,93,94,95 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 2, or (at your option)
9 any later version.
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>
23 #include <config.h>
25 #ifdef VMS
26 #include "vms-pwd.h"
27 #else
28 #include <pwd.h>
29 #endif
31 #include "lisp.h"
32 #include "intervals.h"
33 #include "buffer.h"
34 #include "window.h"
36 #include "systime.h"
38 #define min(a, b) ((a) < (b) ? (a) : (b))
39 #define max(a, b) ((a) > (b) ? (a) : (b))
41 extern char **environ;
42 extern Lisp_Object make_time ();
43 extern void insert_from_buffer ();
44 static long difftm ();
45 static void update_buffer_properties ();
46 void set_time_zone_rule ();
48 Lisp_Object Vbuffer_access_fontify_functions;
49 Lisp_Object Qbuffer_access_fontify_functions;
50 Lisp_Object Vbuffer_access_fontified_property;
52 /* Some static data, and a function to initialize it for each run */
54 Lisp_Object Vsystem_name;
55 Lisp_Object Vuser_real_login_name; /* login name of current user ID */
56 Lisp_Object Vuser_full_name; /* full name of current user */
57 Lisp_Object Vuser_login_name; /* user name from LOGNAME or USER */
59 void
60 init_editfns ()
62 char *user_name;
63 register unsigned char *p, *q, *r;
64 struct passwd *pw; /* password entry for the current user */
65 extern char *index ();
66 Lisp_Object tem;
68 /* Set up system_name even when dumping. */
69 init_system_name ();
71 #ifndef CANNOT_DUMP
72 /* Don't bother with this on initial start when just dumping out */
73 if (!initialized)
74 return;
75 #endif /* not CANNOT_DUMP */
77 pw = (struct passwd *) getpwuid (getuid ());
78 #ifdef MSDOS
79 /* We let the real user name default to "root" because that's quite
80 accurate on MSDOG and because it lets Emacs find the init file.
81 (The DVX libraries override the Djgpp libraries here.) */
82 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
83 #else
84 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
85 #endif
87 /* Get the effective user name, by consulting environment variables,
88 or the effective uid if those are unset. */
89 user_name = (char *) getenv ("LOGNAME");
90 if (!user_name)
91 #ifdef WINDOWSNT
92 user_name = (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
93 #else /* WINDOWSNT */
94 user_name = (char *) getenv ("USER");
95 #endif /* WINDOWSNT */
96 if (!user_name)
98 pw = (struct passwd *) getpwuid (geteuid ());
99 user_name = (char *) (pw ? pw->pw_name : "unknown");
101 Vuser_login_name = build_string (user_name);
103 /* If the user name claimed in the environment vars differs from
104 the real uid, use the claimed name to find the full name. */
105 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
106 if (NILP (tem))
107 pw = (struct passwd *) getpwnam (XSTRING (Vuser_login_name)->data);
109 p = (unsigned char *) (pw ? USER_FULL_NAME : "unknown");
110 q = (unsigned char *) index (p, ',');
111 Vuser_full_name = make_string (p, q ? q - p : strlen (p));
113 #ifdef AMPERSAND_FULL_NAME
114 p = XSTRING (Vuser_full_name)->data;
115 q = (unsigned char *) index (p, '&');
116 /* Substitute the login name for the &, upcasing the first character. */
117 if (q)
119 r = (unsigned char *) alloca (strlen (p)
120 + XSTRING (Vuser_login_name)->size + 1);
121 bcopy (p, r, q - p);
122 r[q - p] = 0;
123 strcat (r, XSTRING (Vuser_login_name)->data);
124 r[q - p] = UPCASE (r[q - p]);
125 strcat (r, q + 1);
126 Vuser_full_name = build_string (r);
128 #endif /* AMPERSAND_FULL_NAME */
130 p = (unsigned char *) getenv ("NAME");
131 if (p)
132 Vuser_full_name = build_string (p);
135 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
136 "Convert arg CHARACTER to a one-character string containing that character.")
137 (character)
138 Lisp_Object character;
140 char c;
141 CHECK_NUMBER (character, 0);
143 c = XINT (character);
144 return make_string (&c, 1);
147 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
148 "Convert arg STRING to a character, the first character of that string.")
149 (string)
150 register Lisp_Object string;
152 register Lisp_Object val;
153 register struct Lisp_String *p;
154 CHECK_STRING (string, 0);
156 p = XSTRING (string);
157 if (p->size)
158 XSETFASTINT (val, ((unsigned char *) p->data)[0]);
159 else
160 XSETFASTINT (val, 0);
161 return val;
164 static Lisp_Object
165 buildmark (val)
166 int val;
168 register Lisp_Object mark;
169 mark = Fmake_marker ();
170 Fset_marker (mark, make_number (val), Qnil);
171 return mark;
174 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
175 "Return value of point, as an integer.\n\
176 Beginning of buffer is position (point-min)")
179 Lisp_Object temp;
180 XSETFASTINT (temp, point);
181 return temp;
184 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
185 "Return value of point, as a marker object.")
188 return buildmark (point);
192 clip_to_bounds (lower, num, upper)
193 int lower, num, upper;
195 if (num < lower)
196 return lower;
197 else if (num > upper)
198 return upper;
199 else
200 return num;
203 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
204 "Set point to POSITION, a number or marker.\n\
205 Beginning of buffer is position (point-min), end is (point-max).")
206 (position)
207 register Lisp_Object position;
209 CHECK_NUMBER_COERCE_MARKER (position, 0);
211 SET_PT (clip_to_bounds (BEGV, XINT (position), ZV));
212 return position;
215 static Lisp_Object
216 region_limit (beginningp)
217 int beginningp;
219 extern Lisp_Object Vmark_even_if_inactive; /* Defined in callint.c. */
220 register Lisp_Object m;
221 if (!NILP (Vtransient_mark_mode) && NILP (Vmark_even_if_inactive)
222 && NILP (current_buffer->mark_active))
223 Fsignal (Qmark_inactive, Qnil);
224 m = Fmarker_position (current_buffer->mark);
225 if (NILP (m)) error ("There is no region now");
226 if ((point < XFASTINT (m)) == beginningp)
227 return (make_number (point));
228 else
229 return (m);
232 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
233 "Return position of beginning of region, as an integer.")
236 return (region_limit (1));
239 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
240 "Return position of end of region, as an integer.")
243 return (region_limit (0));
246 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
247 "Return this buffer's mark, as a marker object.\n\
248 Watch out! Moving this marker changes the mark position.\n\
249 If you set the marker not to point anywhere, the buffer will have no mark.")
252 return current_buffer->mark;
255 Lisp_Object
256 save_excursion_save ()
258 register int visible = (XBUFFER (XWINDOW (selected_window)->buffer)
259 == current_buffer);
261 return Fcons (Fpoint_marker (),
262 Fcons (Fcopy_marker (current_buffer->mark, Qnil),
263 Fcons (visible ? Qt : Qnil,
264 current_buffer->mark_active)));
267 Lisp_Object
268 save_excursion_restore (info)
269 register Lisp_Object info;
271 register Lisp_Object tem, tem1, omark, nmark;
273 tem = Fmarker_buffer (Fcar (info));
274 /* If buffer being returned to is now deleted, avoid error */
275 /* Otherwise could get error here while unwinding to top level
276 and crash */
277 /* In that case, Fmarker_buffer returns nil now. */
278 if (NILP (tem))
279 return Qnil;
280 Fset_buffer (tem);
281 tem = Fcar (info);
282 Fgoto_char (tem);
283 unchain_marker (tem);
284 tem = Fcar (Fcdr (info));
285 omark = Fmarker_position (current_buffer->mark);
286 Fset_marker (current_buffer->mark, tem, Fcurrent_buffer ());
287 nmark = Fmarker_position (tem);
288 unchain_marker (tem);
289 tem = Fcdr (Fcdr (info));
290 #if 0 /* We used to make the current buffer visible in the selected window
291 if that was true previously. That avoids some anomalies.
292 But it creates others, and it wasn't documented, and it is simpler
293 and cleaner never to alter the window/buffer connections. */
294 tem1 = Fcar (tem);
295 if (!NILP (tem1)
296 && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
297 Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
298 #endif /* 0 */
300 tem1 = current_buffer->mark_active;
301 current_buffer->mark_active = Fcdr (tem);
302 if (!NILP (Vrun_hooks))
304 /* If mark is active now, and either was not active
305 or was at a different place, run the activate hook. */
306 if (! NILP (current_buffer->mark_active))
308 if (! EQ (omark, nmark))
309 call1 (Vrun_hooks, intern ("activate-mark-hook"));
311 /* If mark has ceased to be active, run deactivate hook. */
312 else if (! NILP (tem1))
313 call1 (Vrun_hooks, intern ("deactivate-mark-hook"));
315 return Qnil;
318 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
319 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
320 Executes BODY just like `progn'.\n\
321 The values of point, mark and the current buffer are restored\n\
322 even in case of abnormal exit (throw or error).\n\
323 The state of activation of the mark is also restored.")
324 (args)
325 Lisp_Object args;
327 register Lisp_Object val;
328 int count = specpdl_ptr - specpdl;
330 record_unwind_protect (save_excursion_restore, save_excursion_save ());
332 val = Fprogn (args);
333 return unbind_to (count, val);
336 DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 0, 0,
337 "Return the number of characters in the current buffer.")
340 Lisp_Object temp;
341 XSETFASTINT (temp, Z - BEG);
342 return temp;
345 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
346 "Return the minimum permissible value of point in the current buffer.\n\
347 This is 1, unless narrowing (a buffer restriction) is in effect.")
350 Lisp_Object temp;
351 XSETFASTINT (temp, BEGV);
352 return temp;
355 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
356 "Return a marker to the minimum permissible value of point in this buffer.\n\
357 This is the beginning, unless narrowing (a buffer restriction) is in effect.")
360 return buildmark (BEGV);
363 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
364 "Return the maximum permissible value of point in the current buffer.\n\
365 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
366 is in effect, in which case it is less.")
369 Lisp_Object temp;
370 XSETFASTINT (temp, ZV);
371 return temp;
374 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
375 "Return a marker to the maximum permissible value of point in this buffer.\n\
376 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)\n\
377 is in effect, in which case it is less.")
380 return buildmark (ZV);
383 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
384 "Return the character following point, as a number.\n\
385 At the end of the buffer or accessible region, return 0.")
388 Lisp_Object temp;
389 if (point >= ZV)
390 XSETFASTINT (temp, 0);
391 else
392 XSETFASTINT (temp, FETCH_CHAR (point));
393 return temp;
396 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
397 "Return the character preceding point, as a number.\n\
398 At the beginning of the buffer or accessible region, return 0.")
401 Lisp_Object temp;
402 if (point <= BEGV)
403 XSETFASTINT (temp, 0);
404 else
405 XSETFASTINT (temp, FETCH_CHAR (point - 1));
406 return temp;
409 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
410 "Return T if point is at the beginning of the buffer.\n\
411 If the buffer is narrowed, this means the beginning of the narrowed part.")
414 if (point == BEGV)
415 return Qt;
416 return Qnil;
419 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
420 "Return T if point is at the end of the buffer.\n\
421 If the buffer is narrowed, this means the end of the narrowed part.")
424 if (point == ZV)
425 return Qt;
426 return Qnil;
429 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
430 "Return T if point is at the beginning of a line.")
433 if (point == BEGV || FETCH_CHAR (point - 1) == '\n')
434 return Qt;
435 return Qnil;
438 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
439 "Return T if point is at the end of a line.\n\
440 `End of a line' includes point being at the end of the buffer.")
443 if (point == ZV || FETCH_CHAR (point) == '\n')
444 return Qt;
445 return Qnil;
448 DEFUN ("char-after", Fchar_after, Schar_after, 1, 1, 0,
449 "Return character in current buffer at position POS.\n\
450 POS is an integer or a buffer pointer.\n\
451 If POS is out of range, the value is nil.")
452 (pos)
453 Lisp_Object pos;
455 register Lisp_Object val;
456 register int n;
458 CHECK_NUMBER_COERCE_MARKER (pos, 0);
460 n = XINT (pos);
461 if (n < BEGV || n >= ZV) return Qnil;
463 XSETFASTINT (val, FETCH_CHAR (n));
464 return val;
467 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0,
468 "Return the name under which the user logged in, as a string.\n\
469 This is based on the effective uid, not the real uid.\n\
470 Also, if the environment variable LOGNAME or USER is set,\n\
471 that determines the value of this function.\n\n\
472 If optional argument UID is an integer, return the login name of the user\n\
473 with that uid, or nil if there is no such user.")
474 (uid)
475 Lisp_Object uid;
477 struct passwd *pw;
479 /* Set up the user name info if we didn't do it before.
480 (That can happen if Emacs is dumpable
481 but you decide to run `temacs -l loadup' and not dump. */
482 if (INTEGERP (Vuser_login_name))
483 init_editfns ();
485 if (NILP (uid))
486 return Vuser_login_name;
488 CHECK_NUMBER (uid, 0);
489 pw = (struct passwd *) getpwuid (XINT (uid));
490 return (pw ? build_string (pw->pw_name) : Qnil);
493 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
494 0, 0, 0,
495 "Return the name of the user's real uid, as a string.\n\
496 This ignores the environment variables LOGNAME and USER, so it differs from\n\
497 `user-login-name' when running under `su'.")
500 /* Set up the user name info if we didn't do it before.
501 (That can happen if Emacs is dumpable
502 but you decide to run `temacs -l loadup' and not dump. */
503 if (INTEGERP (Vuser_login_name))
504 init_editfns ();
505 return Vuser_real_login_name;
508 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
509 "Return the effective uid of Emacs, as an integer.")
512 return make_number (geteuid ());
515 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
516 "Return the real uid of Emacs, as an integer.")
519 return make_number (getuid ());
522 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 0, 0,
523 "Return the full name of the user logged in, as a string.")
526 return Vuser_full_name;
529 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
530 "Return the name of the machine you are running on, as a string.")
533 return Vsystem_name;
536 /* For the benefit of callers who don't want to include lisp.h */
537 char *
538 get_system_name ()
540 return (char *) XSTRING (Vsystem_name)->data;
543 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0,
544 "Return the process ID of Emacs, as an integer.")
547 return make_number (getpid ());
550 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
551 "Return the current time, as the number of seconds since 1970-01-01 00:00:00.\n\
552 The time is returned as a list of three integers. The first has the\n\
553 most significant 16 bits of the seconds, while the second has the\n\
554 least significant 16 bits. The third integer gives the microsecond\n\
555 count.\n\
557 The microsecond count is zero on systems that do not provide\n\
558 resolution finer than a second.")
561 EMACS_TIME t;
562 Lisp_Object result[3];
564 EMACS_GET_TIME (t);
565 XSETINT (result[0], (EMACS_SECS (t) >> 16) & 0xffff);
566 XSETINT (result[1], (EMACS_SECS (t) >> 0) & 0xffff);
567 XSETINT (result[2], EMACS_USECS (t));
569 return Flist (3, result);
573 static int
574 lisp_time_argument (specified_time, result)
575 Lisp_Object specified_time;
576 time_t *result;
578 if (NILP (specified_time))
579 return time (result) != -1;
580 else
582 Lisp_Object high, low;
583 high = Fcar (specified_time);
584 CHECK_NUMBER (high, 0);
585 low = Fcdr (specified_time);
586 if (CONSP (low))
587 low = Fcar (low);
588 CHECK_NUMBER (low, 0);
589 *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
590 return *result >> 16 == XINT (high);
594 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string, 1, 2, 0,
595 "Use FORMAT-STRING to format the time TIME.\n\
596 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from\n\
597 `current-time' and `file-attributes'.\n\
598 FORMAT-STRING may contain %-sequences to substitute parts of the time.\n\
599 %a is replaced by the abbreviated name of the day of week.\n\
600 %A is replaced by the full name of the day of week.\n\
601 %b is replaced by the abbreviated name of the month.\n\
602 %B is replaced by the full name of the month.\n\
603 %c is a synonym for \"%x %X\".\n\
604 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.\n\
605 %d is replaced by the day of month, zero-padded.\n\
606 %D is a synonym for \"%m/%d/%y\".\n\
607 %e is replaced by the day of month, blank-padded.\n\
608 %h is a synonym for \"%b\".\n\
609 %H is replaced by the hour (00-23).\n\
610 %I is replaced by the hour (00-12).\n\
611 %j is replaced by the day of the year (001-366).\n\
612 %k is replaced by the hour (0-23), blank padded.\n\
613 %l is replaced by the hour (1-12), blank padded.\n\
614 %m is replaced by the month (01-12).\n\
615 %M is replaced by the minute (00-59).\n\
616 %n is a synonym for \"\\n\".\n\
617 %p is replaced by AM or PM, as appropriate.\n\
618 %r is a synonym for \"%I:%M:%S %p\".\n\
619 %R is a synonym for \"%H:%M\".\n\
620 %S is replaced by the second (00-60).\n\
621 %t is a synonym for \"\\t\".\n\
622 %T is a synonym for \"%H:%M:%S\".\n\
623 %U is replaced by the week of the year (01-52), first day of week is Sunday.\n\
624 %w is replaced by the day of week (0-6), Sunday is day 0.\n\
625 %W is replaced by the week of the year (01-52), first day of week is Monday.\n\
626 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.\n\
627 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.\n\
628 %y is replaced by the year without century (00-99).\n\
629 %Y is replaced by the year with century.\n\
630 %Z is replaced by the time zone abbreviation.\n\
632 The number of options reflects the `strftime' function.")
633 (format_string, time)
634 Lisp_Object format_string, time;
636 time_t value;
637 int size;
639 CHECK_STRING (format_string, 1);
641 if (! lisp_time_argument (time, &value))
642 error ("Invalid time specification");
644 /* This is probably enough. */
645 size = XSTRING (format_string)->size * 6 + 50;
647 while (1)
649 char *buf = (char *) alloca (size);
650 *buf = 1;
651 if (emacs_strftime (buf, size, XSTRING (format_string)->data,
652 localtime (&value))
653 || !*buf)
654 return build_string (buf);
655 /* If buffer was too small, make it bigger. */
656 size *= 2;
660 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0,
661 "Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).\n\
662 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)\n\
663 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'\n\
664 to use the current time. The list has the following nine members:\n\
665 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which\n\
666 only some operating systems support. MINUTE is an integer between 0 and 59.\n\
667 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.\n\
668 MONTH is an integer between 1 and 12. YEAR is an integer indicating the\n\
669 four-digit year. DOW is the day of week, an integer between 0 and 6, where\n\
670 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.\n\
671 ZONE is an integer indicating the number of seconds east of Greenwich.\n\
672 \(Note that Common Lisp has different meanings for DOW and ZONE.)")
673 (specified_time)
674 Lisp_Object specified_time;
676 time_t time_spec;
677 struct tm save_tm;
678 struct tm *decoded_time;
679 Lisp_Object list_args[9];
681 if (! lisp_time_argument (specified_time, &time_spec))
682 error ("Invalid time specification");
684 decoded_time = localtime (&time_spec);
685 XSETFASTINT (list_args[0], decoded_time->tm_sec);
686 XSETFASTINT (list_args[1], decoded_time->tm_min);
687 XSETFASTINT (list_args[2], decoded_time->tm_hour);
688 XSETFASTINT (list_args[3], decoded_time->tm_mday);
689 XSETFASTINT (list_args[4], decoded_time->tm_mon + 1);
690 XSETFASTINT (list_args[5], decoded_time->tm_year + 1900);
691 XSETFASTINT (list_args[6], decoded_time->tm_wday);
692 list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil;
694 /* Make a copy, in case gmtime modifies the struct. */
695 save_tm = *decoded_time;
696 decoded_time = gmtime (&time_spec);
697 if (decoded_time == 0)
698 list_args[8] = Qnil;
699 else
700 XSETINT (list_args[8], difftm (&save_tm, decoded_time));
701 return Flist (9, list_args);
704 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, 7, 0,
705 "Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.\n\
706 This is the reverse operation of `decode-time', which see. ZONE defaults\n\
707 to the current time zone rule if not specified; if specified, it can\n\
708 be a string (as from `set-time-zone-rule'), or it can be a list\n\
709 (as from `current-time-zone') or an integer (as from `decode-time')\n\
710 applied without consideration for daylight savings time.\n\
711 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;\n\
712 for example, a DAY of 0 means the day preceding the given month.\n\
713 Year numbers less than 100 are treated just like other year numbers.\n\
714 If you want them to stand for years in this century, you must do that yourself.")
715 (second, minute, hour, day, month, year, zone)
716 Lisp_Object second, minute, hour, day, month, year, zone;
718 time_t time;
719 struct tm tm;
721 CHECK_NUMBER (second, 0);
722 CHECK_NUMBER (minute, 1);
723 CHECK_NUMBER (hour, 2);
724 CHECK_NUMBER (day, 3);
725 CHECK_NUMBER (month, 4);
726 CHECK_NUMBER (year, 5);
728 tm.tm_sec = XINT (second);
729 tm.tm_min = XINT (minute);
730 tm.tm_hour = XINT (hour);
731 tm.tm_mday = XINT (day);
732 tm.tm_mon = XINT (month) - 1;
733 tm.tm_year = XINT (year) - 1900;
734 tm.tm_isdst = -1;
736 if (CONSP (zone))
737 zone = Fcar (zone);
738 if (NILP (zone))
739 time = mktime (&tm);
740 else
742 char tzbuf[100];
743 char *tzstring;
744 char **oldenv = environ, **newenv;
746 if (STRINGP (zone))
747 tzstring = (char *) XSTRING (zone)->data;
748 else if (INTEGERP (zone))
750 int abszone = abs (XINT (zone));
751 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0),
752 abszone / (60*60), (abszone/60) % 60, abszone % 60);
753 tzstring = tzbuf;
755 else
756 error ("Invalid time zone specification");
758 /* Set TZ before calling mktime; merely adjusting mktime's returned
759 value doesn't suffice, since that would mishandle leap seconds. */
760 set_time_zone_rule (tzstring);
762 time = mktime (&tm);
764 /* Restore TZ to previous value. */
765 newenv = environ;
766 environ = oldenv;
767 free (newenv);
768 #ifdef LOCALTIME_CACHE
769 tzset ();
770 #endif
773 if (time == (time_t) -1)
774 error ("Specified time is not representable");
776 return make_time (time);
779 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
780 "Return the current time, as a human-readable string.\n\
781 Programs can use this function to decode a time,\n\
782 since the number of columns in each field is fixed.\n\
783 The format is `Sun Sep 16 01:03:52 1973'.\n\
784 If an argument is given, it specifies a time to format\n\
785 instead of the current time. The argument should have the form:\n\
786 (HIGH . LOW)\n\
787 or the form:\n\
788 (HIGH LOW . IGNORED).\n\
789 Thus, you can use times obtained from `current-time'\n\
790 and from `file-attributes'.")
791 (specified_time)
792 Lisp_Object specified_time;
794 time_t value;
795 char buf[30];
796 register char *tem;
798 if (! lisp_time_argument (specified_time, &value))
799 value = -1;
800 tem = (char *) ctime (&value);
802 strncpy (buf, tem, 24);
803 buf[24] = 0;
805 return build_string (buf);
808 #define TM_YEAR_ORIGIN 1900
810 /* Yield A - B, measured in seconds. */
811 static long
812 difftm (a, b)
813 struct tm *a, *b;
815 int ay = a->tm_year + (TM_YEAR_ORIGIN - 1);
816 int by = b->tm_year + (TM_YEAR_ORIGIN - 1);
817 /* Some compilers can't handle this as a single return statement. */
818 long days = (
819 /* difference in day of year */
820 a->tm_yday - b->tm_yday
821 /* + intervening leap days */
822 + ((ay >> 2) - (by >> 2))
823 - (ay/100 - by/100)
824 + ((ay/100 >> 2) - (by/100 >> 2))
825 /* + difference in years * 365 */
826 + (long)(ay-by) * 365
828 return (60*(60*(24*days + (a->tm_hour - b->tm_hour))
829 + (a->tm_min - b->tm_min))
830 + (a->tm_sec - b->tm_sec));
833 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
834 "Return the offset and name for the local time zone.\n\
835 This returns a list of the form (OFFSET NAME).\n\
836 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
837 A negative value means west of Greenwich.\n\
838 NAME is a string giving the name of the time zone.\n\
839 If an argument is given, it specifies when the time zone offset is determined\n\
840 instead of using the current time. The argument should have the form:\n\
841 (HIGH . LOW)\n\
842 or the form:\n\
843 (HIGH LOW . IGNORED).\n\
844 Thus, you can use times obtained from `current-time'\n\
845 and from `file-attributes'.\n\
847 Some operating systems cannot provide all this information to Emacs;\n\
848 in this case, `current-time-zone' returns a list containing nil for\n\
849 the data it can't find.")
850 (specified_time)
851 Lisp_Object specified_time;
853 time_t value;
854 struct tm *t;
856 if (lisp_time_argument (specified_time, &value)
857 && (t = gmtime (&value)) != 0)
859 struct tm gmt;
860 long offset;
861 char *s, buf[6];
863 gmt = *t; /* Make a copy, in case localtime modifies *t. */
864 t = localtime (&value);
865 offset = difftm (t, &gmt);
866 s = 0;
867 #ifdef HAVE_TM_ZONE
868 if (t->tm_zone)
869 s = (char *)t->tm_zone;
870 #else /* not HAVE_TM_ZONE */
871 #ifdef HAVE_TZNAME
872 if (t->tm_isdst == 0 || t->tm_isdst == 1)
873 s = tzname[t->tm_isdst];
874 #endif
875 #endif /* not HAVE_TM_ZONE */
876 if (!s)
878 /* No local time zone name is available; use "+-NNNN" instead. */
879 int am = (offset < 0 ? -offset : offset) / 60;
880 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
881 s = buf;
883 return Fcons (make_number (offset), Fcons (build_string (s), Qnil));
885 else
886 return Fmake_list (2, Qnil);
889 /* This holds the value of `environ' produced by the previous
890 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
891 has never been called. */
892 static char **environbuf;
894 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule, 1, 1, 0,
895 "Set the local time zone using TZ, a string specifying a time zone rule.\n\
896 If TZ is nil, use implementation-defined default time zone information.")
897 (tz)
898 Lisp_Object tz;
900 char *tzstring;
902 if (NILP (tz))
903 tzstring = 0;
904 else
906 CHECK_STRING (tz, 0);
907 tzstring = (char *) XSTRING (tz)->data;
910 set_time_zone_rule (tzstring);
911 if (environbuf)
912 free (environbuf);
913 environbuf = environ;
915 return Qnil;
918 /* Set the local time zone rule to TZSTRING.
919 This allocates memory into `environ', which it is the caller's
920 responsibility to free. */
921 void
922 set_time_zone_rule (tzstring)
923 char *tzstring;
925 int envptrs;
926 char **from, **to, **newenv;
928 for (from = environ; *from; from++)
929 continue;
930 envptrs = from - environ + 2;
931 newenv = to = (char **) xmalloc (envptrs * sizeof (char *)
932 + (tzstring ? strlen (tzstring) + 4 : 0));
933 if (tzstring)
935 char *t = (char *) (to + envptrs);
936 strcpy (t, "TZ=");
937 strcat (t, tzstring);
938 *to++ = t;
941 for (from = environ; *from; from++)
942 if (strncmp (*from, "TZ=", 3) != 0)
943 *to++ = *from;
944 *to = 0;
946 environ = newenv;
948 #ifdef LOCALTIME_CACHE
949 tzset ();
950 #endif
953 void
954 insert1 (arg)
955 Lisp_Object arg;
957 Finsert (1, &arg);
961 /* Callers passing one argument to Finsert need not gcpro the
962 argument "array", since the only element of the array will
963 not be used after calling insert or insert_from_string, so
964 we don't care if it gets trashed. */
966 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
967 "Insert the arguments, either strings or characters, at point.\n\
968 Point moves forward so that it ends up after the inserted text.\n\
969 Any other markers at the point of insertion remain before the text.")
970 (nargs, args)
971 int nargs;
972 register Lisp_Object *args;
974 register int argnum;
975 register Lisp_Object tem;
976 char str[1];
978 for (argnum = 0; argnum < nargs; argnum++)
980 tem = args[argnum];
981 retry:
982 if (INTEGERP (tem))
984 str[0] = XINT (tem);
985 insert (str, 1);
987 else if (STRINGP (tem))
989 insert_from_string (tem, 0, XSTRING (tem)->size, 0);
991 else
993 tem = wrong_type_argument (Qchar_or_string_p, tem);
994 goto retry;
998 return Qnil;
1001 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
1002 0, MANY, 0,
1003 "Insert the arguments at point, inheriting properties from adjoining text.\n\
1004 Point moves forward so that it ends up after the inserted text.\n\
1005 Any other markers at the point of insertion remain before the text.")
1006 (nargs, args)
1007 int nargs;
1008 register Lisp_Object *args;
1010 register int argnum;
1011 register Lisp_Object tem;
1012 char str[1];
1014 for (argnum = 0; argnum < nargs; argnum++)
1016 tem = args[argnum];
1017 retry:
1018 if (INTEGERP (tem))
1020 str[0] = XINT (tem);
1021 insert_and_inherit (str, 1);
1023 else if (STRINGP (tem))
1025 insert_from_string (tem, 0, XSTRING (tem)->size, 1);
1027 else
1029 tem = wrong_type_argument (Qchar_or_string_p, tem);
1030 goto retry;
1034 return Qnil;
1037 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
1038 "Insert strings or characters at point, relocating markers after the text.\n\
1039 Point moves forward so that it ends up after the inserted text.\n\
1040 Any other markers at the point of insertion also end up after the text.")
1041 (nargs, args)
1042 int nargs;
1043 register Lisp_Object *args;
1045 register int argnum;
1046 register Lisp_Object tem;
1047 char str[1];
1049 for (argnum = 0; argnum < nargs; argnum++)
1051 tem = args[argnum];
1052 retry:
1053 if (INTEGERP (tem))
1055 str[0] = XINT (tem);
1056 insert_before_markers (str, 1);
1058 else if (STRINGP (tem))
1060 insert_from_string_before_markers (tem, 0, XSTRING (tem)->size, 0);
1062 else
1064 tem = wrong_type_argument (Qchar_or_string_p, tem);
1065 goto retry;
1069 return Qnil;
1072 DEFUN ("insert-before-markers-and-inherit",
1073 Finsert_and_inherit_before_markers, Sinsert_and_inherit_before_markers,
1074 0, MANY, 0,
1075 "Insert text at point, relocating markers and inheriting properties.\n\
1076 Point moves forward so that it ends up after the inserted text.\n\
1077 Any other markers at the point of insertion also end up after the text.")
1078 (nargs, args)
1079 int nargs;
1080 register Lisp_Object *args;
1082 register int argnum;
1083 register Lisp_Object tem;
1084 char str[1];
1086 for (argnum = 0; argnum < nargs; argnum++)
1088 tem = args[argnum];
1089 retry:
1090 if (INTEGERP (tem))
1092 str[0] = XINT (tem);
1093 insert_before_markers_and_inherit (str, 1);
1095 else if (STRINGP (tem))
1097 insert_from_string_before_markers (tem, 0, XSTRING (tem)->size, 1);
1099 else
1101 tem = wrong_type_argument (Qchar_or_string_p, tem);
1102 goto retry;
1106 return Qnil;
1109 DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 3, 0,
1110 "Insert COUNT (second arg) copies of CHARACTER (first arg).\n\
1111 Point and all markers are affected as in the function `insert'.\n\
1112 Both arguments are required.\n\
1113 The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1114 from adjoining text, if those properties are sticky.")
1115 (character, count, inherit)
1116 Lisp_Object character, count, inherit;
1118 register unsigned char *string;
1119 register int strlen;
1120 register int i, n;
1122 CHECK_NUMBER (character, 0);
1123 CHECK_NUMBER (count, 1);
1125 n = XINT (count);
1126 if (n <= 0)
1127 return Qnil;
1128 strlen = min (n, 256);
1129 string = (unsigned char *) alloca (strlen);
1130 for (i = 0; i < strlen; i++)
1131 string[i] = XFASTINT (character);
1132 while (n >= strlen)
1134 if (!NILP (inherit))
1135 insert_and_inherit (string, strlen);
1136 else
1137 insert (string, strlen);
1138 n -= strlen;
1140 if (n > 0)
1142 if (!NILP (inherit))
1143 insert_and_inherit (string, n);
1144 else
1145 insert (string, n);
1147 return Qnil;
1151 /* Making strings from buffer contents. */
1153 /* Return a Lisp_String containing the text of the current buffer from
1154 START to END. If text properties are in use and the current buffer
1155 has properties in the range specified, the resulting string will also
1156 have them, if PROPS is nonzero.
1158 We don't want to use plain old make_string here, because it calls
1159 make_uninit_string, which can cause the buffer arena to be
1160 compacted. make_string has no way of knowing that the data has
1161 been moved, and thus copies the wrong data into the string. This
1162 doesn't effect most of the other users of make_string, so it should
1163 be left as is. But we should use this function when conjuring
1164 buffer substrings. */
1166 Lisp_Object
1167 make_buffer_string (start, end, props)
1168 int start, end;
1169 int props;
1171 Lisp_Object result, tem, tem1;
1173 if (start < GPT && GPT < end)
1174 move_gap (start);
1176 result = make_uninit_string (end - start);
1177 bcopy (&FETCH_CHAR (start), XSTRING (result)->data, end - start);
1179 /* If desired, update and copy the text properties. */
1180 #ifdef USE_TEXT_PROPERTIES
1181 if (props)
1183 update_buffer_properties (start, end);
1185 tem = Fnext_property_change (make_number (start), Qnil, make_number (end));
1186 tem1 = Ftext_properties_at (make_number (start), Qnil);
1188 if (XINT (tem) != end || !NILP (tem1))
1189 copy_intervals_to_string (result, current_buffer, start, end - start);
1191 #endif
1193 return result;
1196 /* Call Vbuffer_access_fontify_functions for the range START ... END
1197 in the current buffer, if necessary. */
1199 static void
1200 update_buffer_properties (start, end)
1201 int start, end;
1203 #ifdef USE_TEXT_PROPERTIES
1204 /* If this buffer has some access functions,
1205 call them, specifying the range of the buffer being accessed. */
1206 if (!NILP (Vbuffer_access_fontify_functions))
1208 Lisp_Object args[3];
1209 Lisp_Object tem;
1211 args[0] = Qbuffer_access_fontify_functions;
1212 XSETINT (args[1], start);
1213 XSETINT (args[2], end);
1215 /* But don't call them if we can tell that the work
1216 has already been done. */
1217 if (!NILP (Vbuffer_access_fontified_property))
1219 tem = Ftext_property_any (args[1], args[2],
1220 Vbuffer_access_fontified_property,
1221 Qnil, Qnil);
1222 if (! NILP (tem))
1223 Frun_hook_with_args (3, args);
1225 else
1226 Frun_hook_with_args (3, args);
1228 #endif
1231 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
1232 "Return the contents of part of the current buffer as a string.\n\
1233 The two arguments START and END are character positions;\n\
1234 they can be in either order.")
1235 (start, end)
1236 Lisp_Object start, end;
1238 register int b, e;
1240 validate_region (&start, &end);
1241 b = XINT (start);
1242 e = XINT (end);
1244 return make_buffer_string (b, e, 1);
1247 DEFUN ("buffer-substring-no-properties", Fbuffer_substring_no_properties,
1248 Sbuffer_substring_no_properties, 2, 2, 0,
1249 "Return the characters of part of the buffer, without the text properties.\n\
1250 The two arguments START and END are character positions;\n\
1251 they can be in either order.")
1252 (start, end)
1253 Lisp_Object start, end;
1255 register int b, e;
1257 validate_region (&start, &end);
1258 b = XINT (start);
1259 e = XINT (end);
1261 return make_buffer_string (b, e, 0);
1264 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
1265 "Return the contents of the current buffer as a string.\n\
1266 If narrowing is in effect, this function returns only the visible part\n\
1267 of the buffer.")
1270 return make_buffer_string (BEGV, ZV, 1);
1273 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
1274 1, 3, 0,
1275 "Insert before point a substring of the contents of buffer BUFFER.\n\
1276 BUFFER may be a buffer or a buffer name.\n\
1277 Arguments START and END are character numbers specifying the substring.\n\
1278 They default to the beginning and the end of BUFFER.")
1279 (buf, start, end)
1280 Lisp_Object buf, start, end;
1282 register int b, e, temp;
1283 register struct buffer *bp, *obuf;
1284 Lisp_Object buffer;
1286 buffer = Fget_buffer (buf);
1287 if (NILP (buffer))
1288 nsberror (buf);
1289 bp = XBUFFER (buffer);
1291 if (NILP (start))
1292 b = BUF_BEGV (bp);
1293 else
1295 CHECK_NUMBER_COERCE_MARKER (start, 0);
1296 b = XINT (start);
1298 if (NILP (end))
1299 e = BUF_ZV (bp);
1300 else
1302 CHECK_NUMBER_COERCE_MARKER (end, 1);
1303 e = XINT (end);
1306 if (b > e)
1307 temp = b, b = e, e = temp;
1309 if (!(BUF_BEGV (bp) <= b && e <= BUF_ZV (bp)))
1310 args_out_of_range (start, end);
1312 obuf = current_buffer;
1313 set_buffer_internal_1 (bp);
1314 update_buffer_properties (b, e);
1315 set_buffer_internal_1 (obuf);
1317 insert_from_buffer (bp, b, e - b, 0);
1318 return Qnil;
1321 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
1322 6, 6, 0,
1323 "Compare two substrings of two buffers; return result as number.\n\
1324 the value is -N if first string is less after N-1 chars,\n\
1325 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1326 Each substring is represented as three arguments: BUFFER, START and END.\n\
1327 That makes six args in all, three for each substring.\n\n\
1328 The value of `case-fold-search' in the current buffer\n\
1329 determines whether case is significant or ignored.")
1330 (buffer1, start1, end1, buffer2, start2, end2)
1331 Lisp_Object buffer1, start1, end1, buffer2, start2, end2;
1333 register int begp1, endp1, begp2, endp2, temp, len1, len2, length, i;
1334 register struct buffer *bp1, *bp2;
1335 register Lisp_Object *trt
1336 = (!NILP (current_buffer->case_fold_search)
1337 ? XCHAR_TABLE (current_buffer->case_canon_table)->contents : 0);
1339 /* Find the first buffer and its substring. */
1341 if (NILP (buffer1))
1342 bp1 = current_buffer;
1343 else
1345 Lisp_Object buf1;
1346 buf1 = Fget_buffer (buffer1);
1347 if (NILP (buf1))
1348 nsberror (buffer1);
1349 bp1 = XBUFFER (buf1);
1352 if (NILP (start1))
1353 begp1 = BUF_BEGV (bp1);
1354 else
1356 CHECK_NUMBER_COERCE_MARKER (start1, 1);
1357 begp1 = XINT (start1);
1359 if (NILP (end1))
1360 endp1 = BUF_ZV (bp1);
1361 else
1363 CHECK_NUMBER_COERCE_MARKER (end1, 2);
1364 endp1 = XINT (end1);
1367 if (begp1 > endp1)
1368 temp = begp1, begp1 = endp1, endp1 = temp;
1370 if (!(BUF_BEGV (bp1) <= begp1
1371 && begp1 <= endp1
1372 && endp1 <= BUF_ZV (bp1)))
1373 args_out_of_range (start1, end1);
1375 /* Likewise for second substring. */
1377 if (NILP (buffer2))
1378 bp2 = current_buffer;
1379 else
1381 Lisp_Object buf2;
1382 buf2 = Fget_buffer (buffer2);
1383 if (NILP (buf2))
1384 nsberror (buffer2);
1385 bp2 = XBUFFER (buffer2);
1388 if (NILP (start2))
1389 begp2 = BUF_BEGV (bp2);
1390 else
1392 CHECK_NUMBER_COERCE_MARKER (start2, 4);
1393 begp2 = XINT (start2);
1395 if (NILP (end2))
1396 endp2 = BUF_ZV (bp2);
1397 else
1399 CHECK_NUMBER_COERCE_MARKER (end2, 5);
1400 endp2 = XINT (end2);
1403 if (begp2 > endp2)
1404 temp = begp2, begp2 = endp2, endp2 = temp;
1406 if (!(BUF_BEGV (bp2) <= begp2
1407 && begp2 <= endp2
1408 && endp2 <= BUF_ZV (bp2)))
1409 args_out_of_range (start2, end2);
1411 len1 = endp1 - begp1;
1412 len2 = endp2 - begp2;
1413 length = len1;
1414 if (len2 < length)
1415 length = len2;
1417 for (i = 0; i < length; i++)
1419 int c1 = *BUF_CHAR_ADDRESS (bp1, begp1 + i);
1420 int c2 = *BUF_CHAR_ADDRESS (bp2, begp2 + i);
1421 if (trt)
1423 c1 = trt[c1];
1424 c2 = trt[c2];
1426 if (c1 < c2)
1427 return make_number (- 1 - i);
1428 if (c1 > c2)
1429 return make_number (i + 1);
1432 /* The strings match as far as they go.
1433 If one is shorter, that one is less. */
1434 if (length < len1)
1435 return make_number (length + 1);
1436 else if (length < len2)
1437 return make_number (- length - 1);
1439 /* Same length too => they are equal. */
1440 return make_number (0);
1443 static Lisp_Object
1444 subst_char_in_region_unwind (arg)
1445 Lisp_Object arg;
1447 return current_buffer->undo_list = arg;
1450 static Lisp_Object
1451 subst_char_in_region_unwind_1 (arg)
1452 Lisp_Object arg;
1454 return current_buffer->filename = arg;
1457 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
1458 Ssubst_char_in_region, 4, 5, 0,
1459 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1460 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1461 and don't mark the buffer as really changed.")
1462 (start, end, fromchar, tochar, noundo)
1463 Lisp_Object start, end, fromchar, tochar, noundo;
1465 register int pos, stop, look;
1466 int changed = 0;
1467 int count = specpdl_ptr - specpdl;
1469 validate_region (&start, &end);
1470 CHECK_NUMBER (fromchar, 2);
1471 CHECK_NUMBER (tochar, 3);
1473 pos = XINT (start);
1474 stop = XINT (end);
1475 look = XINT (fromchar);
1477 /* If we don't want undo, turn off putting stuff on the list.
1478 That's faster than getting rid of things,
1479 and it prevents even the entry for a first change.
1480 Also inhibit locking the file. */
1481 if (!NILP (noundo))
1483 record_unwind_protect (subst_char_in_region_unwind,
1484 current_buffer->undo_list);
1485 current_buffer->undo_list = Qt;
1486 /* Don't do file-locking. */
1487 record_unwind_protect (subst_char_in_region_unwind_1,
1488 current_buffer->filename);
1489 current_buffer->filename = Qnil;
1492 while (pos < stop)
1494 if (FETCH_CHAR (pos) == look)
1496 if (! changed)
1498 modify_region (current_buffer, XINT (start), stop);
1500 if (! NILP (noundo))
1502 if (MODIFF - 1 == SAVE_MODIFF)
1503 SAVE_MODIFF++;
1504 if (MODIFF - 1 == current_buffer->auto_save_modified)
1505 current_buffer->auto_save_modified++;
1508 changed = 1;
1511 if (NILP (noundo))
1512 record_change (pos, 1);
1513 FETCH_CHAR (pos) = XINT (tochar);
1515 pos++;
1518 if (changed)
1519 signal_after_change (XINT (start),
1520 stop - XINT (start), stop - XINT (start));
1522 unbind_to (count, Qnil);
1523 return Qnil;
1526 DEFUN ("translate-region", Ftranslate_region, Stranslate_region, 3, 3, 0,
1527 "From START to END, translate characters according to TABLE.\n\
1528 TABLE is a string; the Nth character in it is the mapping\n\
1529 for the character with code N. Returns the number of characters changed.")
1530 (start, end, table)
1531 Lisp_Object start;
1532 Lisp_Object end;
1533 register Lisp_Object table;
1535 register int pos, stop; /* Limits of the region. */
1536 register unsigned char *tt; /* Trans table. */
1537 register int oc; /* Old character. */
1538 register int nc; /* New character. */
1539 int cnt; /* Number of changes made. */
1540 Lisp_Object z; /* Return. */
1541 int size; /* Size of translate table. */
1543 validate_region (&start, &end);
1544 CHECK_STRING (table, 2);
1546 size = XSTRING (table)->size;
1547 tt = XSTRING (table)->data;
1549 pos = XINT (start);
1550 stop = XINT (end);
1551 modify_region (current_buffer, pos, stop);
1553 cnt = 0;
1554 for (; pos < stop; ++pos)
1556 oc = FETCH_CHAR (pos);
1557 if (oc < size)
1559 nc = tt[oc];
1560 if (nc != oc)
1562 record_change (pos, 1);
1563 FETCH_CHAR (pos) = nc;
1564 signal_after_change (pos, 1, 1);
1565 ++cnt;
1570 XSETFASTINT (z, cnt);
1571 return (z);
1574 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
1575 "Delete the text between point and mark.\n\
1576 When called from a program, expects two arguments,\n\
1577 positions (integers or markers) specifying the stretch to be deleted.")
1578 (start, end)
1579 Lisp_Object start, end;
1581 validate_region (&start, &end);
1582 del_range (XINT (start), XINT (end));
1583 return Qnil;
1586 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
1587 "Remove restrictions (narrowing) from current buffer.\n\
1588 This allows the buffer's full text to be seen and edited.")
1591 BEGV = BEG;
1592 SET_BUF_ZV (current_buffer, Z);
1593 current_buffer->clip_changed = 1;
1594 /* Changing the buffer bounds invalidates any recorded current column. */
1595 invalidate_current_column ();
1596 return Qnil;
1599 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
1600 "Restrict editing in this buffer to the current region.\n\
1601 The rest of the text becomes temporarily invisible and untouchable\n\
1602 but is not deleted; if you save the buffer in a file, the invisible\n\
1603 text is included in the file. \\[widen] makes all visible again.\n\
1604 See also `save-restriction'.\n\
1606 When calling from a program, pass two arguments; positions (integers\n\
1607 or markers) bounding the text that should remain visible.")
1608 (start, end)
1609 register Lisp_Object start, end;
1611 CHECK_NUMBER_COERCE_MARKER (start, 0);
1612 CHECK_NUMBER_COERCE_MARKER (end, 1);
1614 if (XINT (start) > XINT (end))
1616 Lisp_Object tem;
1617 tem = start; start = end; end = tem;
1620 if (!(BEG <= XINT (start) && XINT (start) <= XINT (end) && XINT (end) <= Z))
1621 args_out_of_range (start, end);
1623 BEGV = XFASTINT (start);
1624 SET_BUF_ZV (current_buffer, XFASTINT (end));
1625 if (point < XFASTINT (start))
1626 SET_PT (XFASTINT (start));
1627 if (point > XFASTINT (end))
1628 SET_PT (XFASTINT (end));
1629 current_buffer->clip_changed = 1;
1630 /* Changing the buffer bounds invalidates any recorded current column. */
1631 invalidate_current_column ();
1632 return Qnil;
1635 Lisp_Object
1636 save_restriction_save ()
1638 register Lisp_Object bottom, top;
1639 /* Note: I tried using markers here, but it does not win
1640 because insertion at the end of the saved region
1641 does not advance mh and is considered "outside" the saved region. */
1642 XSETFASTINT (bottom, BEGV - BEG);
1643 XSETFASTINT (top, Z - ZV);
1645 return Fcons (Fcurrent_buffer (), Fcons (bottom, top));
1648 Lisp_Object
1649 save_restriction_restore (data)
1650 Lisp_Object data;
1652 register struct buffer *buf;
1653 register int newhead, newtail;
1654 register Lisp_Object tem;
1656 buf = XBUFFER (XCONS (data)->car);
1658 data = XCONS (data)->cdr;
1660 tem = XCONS (data)->car;
1661 newhead = XINT (tem);
1662 tem = XCONS (data)->cdr;
1663 newtail = XINT (tem);
1664 if (newhead + newtail > BUF_Z (buf) - BUF_BEG (buf))
1666 newhead = 0;
1667 newtail = 0;
1669 BUF_BEGV (buf) = BUF_BEG (buf) + newhead;
1670 SET_BUF_ZV (buf, BUF_Z (buf) - newtail);
1671 current_buffer->clip_changed = 1;
1673 /* If point is outside the new visible range, move it inside. */
1674 SET_BUF_PT (buf,
1675 clip_to_bounds (BUF_BEGV (buf), BUF_PT (buf), BUF_ZV (buf)));
1677 return Qnil;
1680 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
1681 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1682 The buffer's restrictions make parts of the beginning and end invisible.\n\
1683 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1684 This special form, `save-restriction', saves the current buffer's restrictions\n\
1685 when it is entered, and restores them when it is exited.\n\
1686 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1687 The old restrictions settings are restored\n\
1688 even in case of abnormal exit (throw or error).\n\
1690 The value returned is the value of the last form in BODY.\n\
1692 `save-restriction' can get confused if, within the BODY, you widen\n\
1693 and then make changes outside the area within the saved restrictions.\n\
1695 Note: if you are using both `save-excursion' and `save-restriction',\n\
1696 use `save-excursion' outermost:\n\
1697 (save-excursion (save-restriction ...))")
1698 (body)
1699 Lisp_Object body;
1701 register Lisp_Object val;
1702 int count = specpdl_ptr - specpdl;
1704 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1705 val = Fprogn (body);
1706 return unbind_to (count, val);
1709 /* Buffer for the most recent text displayed by Fmessage. */
1710 static char *message_text;
1712 /* Allocated length of that buffer. */
1713 static int message_length;
1715 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
1716 "Print a one-line message at the bottom of the screen.\n\
1717 The first argument is a format control string, and the rest are data\n\
1718 to be formatted under control of the string. See `format' for details.\n\
1720 If the first argument is nil, clear any existing message; let the\n\
1721 minibuffer contents show.")
1722 (nargs, args)
1723 int nargs;
1724 Lisp_Object *args;
1726 if (NILP (args[0]))
1728 message (0);
1729 return Qnil;
1731 else
1733 register Lisp_Object val;
1734 val = Fformat (nargs, args);
1735 /* Copy the data so that it won't move when we GC. */
1736 if (! message_text)
1738 message_text = (char *)xmalloc (80);
1739 message_length = 80;
1741 if (XSTRING (val)->size > message_length)
1743 message_length = XSTRING (val)->size;
1744 message_text = (char *)xrealloc (message_text, message_length);
1746 bcopy (XSTRING (val)->data, message_text, XSTRING (val)->size);
1747 message2 (message_text, XSTRING (val)->size);
1748 return val;
1752 DEFUN ("message-box", Fmessage_box, Smessage_box, 1, MANY, 0,
1753 "Display a message, in a dialog box if possible.\n\
1754 If a dialog box is not available, use the echo area.\n\
1755 The first argument is a format control string, and the rest are data\n\
1756 to be formatted under control of the string. See `format' for details.\n\
1758 If the first argument is nil, clear any existing message; let the\n\
1759 minibuffer contents show.")
1760 (nargs, args)
1761 int nargs;
1762 Lisp_Object *args;
1764 if (NILP (args[0]))
1766 message (0);
1767 return Qnil;
1769 else
1771 register Lisp_Object val;
1772 val = Fformat (nargs, args);
1773 #ifdef HAVE_MENUS
1775 Lisp_Object pane, menu, obj;
1776 struct gcpro gcpro1;
1777 pane = Fcons (Fcons (build_string ("OK"), Qt), Qnil);
1778 GCPRO1 (pane);
1779 menu = Fcons (val, pane);
1780 obj = Fx_popup_dialog (Qt, menu);
1781 UNGCPRO;
1782 return val;
1784 #else /* not HAVE_MENUS */
1785 /* Copy the data so that it won't move when we GC. */
1786 if (! message_text)
1788 message_text = (char *)xmalloc (80);
1789 message_length = 80;
1791 if (XSTRING (val)->size > message_length)
1793 message_length = XSTRING (val)->size;
1794 message_text = (char *)xrealloc (message_text, message_length);
1796 bcopy (XSTRING (val)->data, message_text, XSTRING (val)->size);
1797 message2 (message_text, XSTRING (val)->size);
1798 return val;
1799 #endif /* not HAVE_MENUS */
1802 #ifdef HAVE_MENUS
1803 extern Lisp_Object last_nonmenu_event;
1804 #endif
1806 DEFUN ("message-or-box", Fmessage_or_box, Smessage_or_box, 1, MANY, 0,
1807 "Display a message in a dialog box or in the echo area.\n\
1808 If this command was invoked with the mouse, use a dialog box.\n\
1809 Otherwise, use the echo area.\n\
1810 The first argument is a format control string, and the rest are data\n\
1811 to be formatted under control of the string. See `format' for details.\n\
1813 If the first argument is nil, clear any existing message; let the\n\
1814 minibuffer contents show.")
1815 (nargs, args)
1816 int nargs;
1817 Lisp_Object *args;
1819 #ifdef HAVE_MENUS
1820 if (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
1821 return Fmessage_box (nargs, args);
1822 #endif
1823 return Fmessage (nargs, args);
1826 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
1827 "Format a string out of a control-string and arguments.\n\
1828 The first argument is a control string.\n\
1829 The other arguments are substituted into it to make the result, a string.\n\
1830 It may contain %-sequences meaning to substitute the next argument.\n\
1831 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1832 %d means print as number in decimal (%o octal, %x hex).\n\
1833 %e means print a number in exponential notation.\n\
1834 %f means print a number in decimal-point notation.\n\
1835 %g means print a number in exponential notation\n\
1836 or decimal-point notation, whichever uses fewer characters.\n\
1837 %c means print a number as a single character.\n\
1838 %S means print any object as an s-expression (using prin1).\n\
1839 The argument used for %d, %o, %x, %e, %f, %g or %c must be a number.\n\
1840 Use %% to put a single % into the output.")
1841 (nargs, args)
1842 int nargs;
1843 register Lisp_Object *args;
1845 register int n; /* The number of the next arg to substitute */
1846 register int total = 5; /* An estimate of the final length */
1847 char *buf;
1848 register unsigned char *format, *end;
1849 int length;
1850 extern char *index ();
1851 /* It should not be necessary to GCPRO ARGS, because
1852 the caller in the interpreter should take care of that. */
1854 CHECK_STRING (args[0], 0);
1855 format = XSTRING (args[0])->data;
1856 end = format + XSTRING (args[0])->size;
1858 n = 0;
1859 while (format != end)
1860 if (*format++ == '%')
1862 int minlen;
1864 /* Process a numeric arg and skip it. */
1865 minlen = atoi (format);
1866 if (minlen < 0)
1867 minlen = - minlen;
1869 while ((*format >= '0' && *format <= '9')
1870 || *format == '-' || *format == ' ' || *format == '.')
1871 format++;
1873 if (*format == '%')
1874 format++;
1875 else if (++n >= nargs)
1876 error ("Not enough arguments for format string");
1877 else if (*format == 'S')
1879 /* For `S', prin1 the argument and then treat like a string. */
1880 register Lisp_Object tem;
1881 tem = Fprin1_to_string (args[n], Qnil);
1882 args[n] = tem;
1883 goto string;
1885 else if (SYMBOLP (args[n]))
1887 XSETSTRING (args[n], XSYMBOL (args[n])->name);
1888 goto string;
1890 else if (STRINGP (args[n]))
1892 string:
1893 if (*format != 's' && *format != 'S')
1894 error ("format specifier doesn't match argument type");
1895 total += XSTRING (args[n])->size;
1896 /* We have to put an arbitrary limit on minlen
1897 since otherwise it could make alloca fail. */
1898 if (minlen < XSTRING (args[n])->size + 1000)
1899 total += minlen;
1901 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1902 else if (INTEGERP (args[n]) && *format != 's')
1904 #ifdef LISP_FLOAT_TYPE
1905 /* The following loop assumes the Lisp type indicates
1906 the proper way to pass the argument.
1907 So make sure we have a flonum if the argument should
1908 be a double. */
1909 if (*format == 'e' || *format == 'f' || *format == 'g')
1910 args[n] = Ffloat (args[n]);
1911 #endif
1912 total += 30;
1913 /* We have to put an arbitrary limit on minlen
1914 since otherwise it could make alloca fail. */
1915 if (minlen < 1000)
1916 total += minlen;
1918 #ifdef LISP_FLOAT_TYPE
1919 else if (FLOATP (args[n]) && *format != 's')
1921 if (! (*format == 'e' || *format == 'f' || *format == 'g'))
1922 args[n] = Ftruncate (args[n]);
1923 total += 30;
1924 /* We have to put an arbitrary limit on minlen
1925 since otherwise it could make alloca fail. */
1926 if (minlen < 1000)
1927 total += minlen;
1929 #endif
1930 else
1932 /* Anything but a string, convert to a string using princ. */
1933 register Lisp_Object tem;
1934 tem = Fprin1_to_string (args[n], Qt);
1935 args[n] = tem;
1936 goto string;
1941 register int nstrings = n + 1;
1943 /* Allocate twice as many strings as we have %-escapes; floats occupy
1944 two slots, and we're not sure how many of those we have. */
1945 register unsigned char **strings
1946 = (unsigned char **) alloca (2 * nstrings * sizeof (unsigned char *));
1947 int i;
1949 i = 0;
1950 for (n = 0; n < nstrings; n++)
1952 if (n >= nargs)
1953 strings[i++] = (unsigned char *) "";
1954 else if (INTEGERP (args[n]))
1955 /* We checked above that the corresponding format effector
1956 isn't %s, which would cause MPV. */
1957 strings[i++] = (unsigned char *) XINT (args[n]);
1958 #ifdef LISP_FLOAT_TYPE
1959 else if (FLOATP (args[n]))
1961 union { double d; char *half[2]; } u;
1963 u.d = XFLOAT (args[n])->data;
1964 strings[i++] = (unsigned char *) u.half[0];
1965 strings[i++] = (unsigned char *) u.half[1];
1967 #endif
1968 else if (i == 0)
1969 /* The first string is treated differently
1970 because it is the format string. */
1971 strings[i++] = XSTRING (args[n])->data;
1972 else
1973 strings[i++] = (unsigned char *) XFASTINT (args[n]);
1976 /* Make room in result for all the non-%-codes in the control string. */
1977 total += XSTRING (args[0])->size;
1979 /* Format it in bigger and bigger buf's until it all fits. */
1980 while (1)
1982 buf = (char *) alloca (total + 1);
1983 buf[total - 1] = 0;
1985 length = doprnt_lisp (buf, total + 1, strings[0],
1986 end, i-1, strings + 1);
1987 if (buf[total - 1] == 0)
1988 break;
1990 total *= 2;
1994 /* UNGCPRO; */
1995 return make_string (buf, length);
1998 /* VARARGS 1 */
1999 Lisp_Object
2000 #ifdef NO_ARG_ARRAY
2001 format1 (string1, arg0, arg1, arg2, arg3, arg4)
2002 EMACS_INT arg0, arg1, arg2, arg3, arg4;
2003 #else
2004 format1 (string1)
2005 #endif
2006 char *string1;
2008 char buf[100];
2009 #ifdef NO_ARG_ARRAY
2010 EMACS_INT args[5];
2011 args[0] = arg0;
2012 args[1] = arg1;
2013 args[2] = arg2;
2014 args[3] = arg3;
2015 args[4] = arg4;
2016 doprnt (buf, sizeof buf, string1, (char *)0, 5, args);
2017 #else
2018 doprnt (buf, sizeof buf, string1, (char *)0, 5, &string1 + 1);
2019 #endif
2020 return build_string (buf);
2023 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
2024 "Return t if two characters match, optionally ignoring case.\n\
2025 Both arguments must be characters (i.e. integers).\n\
2026 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
2027 (c1, c2)
2028 register Lisp_Object c1, c2;
2030 Lisp_Object *downcase = DOWNCASE_TABLE;
2031 CHECK_NUMBER (c1, 0);
2032 CHECK_NUMBER (c2, 1);
2034 if (!NILP (current_buffer->case_fold_search)
2035 ? ((XINT (downcase[0xff & XFASTINT (c1)])
2036 == XINT (downcase[0xff & XFASTINT (c2)]))
2037 && (XFASTINT (c1) & ~0xff) == (XFASTINT (c2) & ~0xff))
2038 : XINT (c1) == XINT (c2))
2039 return Qt;
2040 return Qnil;
2043 /* Transpose the markers in two regions of the current buffer, and
2044 adjust the ones between them if necessary (i.e.: if the regions
2045 differ in size).
2047 Traverses the entire marker list of the buffer to do so, adding an
2048 appropriate amount to some, subtracting from some, and leaving the
2049 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2051 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
2053 void
2054 transpose_markers (start1, end1, start2, end2)
2055 register int start1, end1, start2, end2;
2057 register int amt1, amt2, diff, mpos;
2058 register Lisp_Object marker;
2060 /* Update point as if it were a marker. */
2061 if (PT < start1)
2063 else if (PT < end1)
2064 TEMP_SET_PT (PT + (end2 - end1));
2065 else if (PT < start2)
2066 TEMP_SET_PT (PT + (end2 - start2) - (end1 - start1));
2067 else if (PT < end2)
2068 TEMP_SET_PT (PT - (start2 - start1));
2070 /* We used to adjust the endpoints here to account for the gap, but that
2071 isn't good enough. Even if we assume the caller has tried to move the
2072 gap out of our way, it might still be at start1 exactly, for example;
2073 and that places it `inside' the interval, for our purposes. The amount
2074 of adjustment is nontrivial if there's a `denormalized' marker whose
2075 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2076 the dirty work to Fmarker_position, below. */
2078 /* The difference between the region's lengths */
2079 diff = (end2 - start2) - (end1 - start1);
2081 /* For shifting each marker in a region by the length of the other
2082 * region plus the distance between the regions.
2084 amt1 = (end2 - start2) + (start2 - end1);
2085 amt2 = (end1 - start1) + (start2 - end1);
2087 for (marker = BUF_MARKERS (current_buffer); !NILP (marker);
2088 marker = XMARKER (marker)->chain)
2090 mpos = Fmarker_position (marker);
2091 if (mpos >= start1 && mpos < end2)
2093 if (mpos < end1)
2094 mpos += amt1;
2095 else if (mpos < start2)
2096 mpos += diff;
2097 else
2098 mpos -= amt2;
2099 if (mpos > GPT) mpos += GAP_SIZE;
2100 XMARKER (marker)->bufpos = mpos;
2105 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0,
2106 "Transpose region START1 to END1 with START2 to END2.\n\
2107 The regions may not be overlapping, because the size of the buffer is\n\
2108 never changed in a transposition.\n\
2110 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose\n\
2111 any markers that happen to be located in the regions.\n\
2113 Transposing beyond buffer boundaries is an error.")
2114 (startr1, endr1, startr2, endr2, leave_markers)
2115 Lisp_Object startr1, endr1, startr2, endr2, leave_markers;
2117 register int start1, end1, start2, end2,
2118 gap, len1, len_mid, len2;
2119 unsigned char *start1_addr, *start2_addr, *temp;
2121 #ifdef USE_TEXT_PROPERTIES
2122 INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2;
2123 cur_intv = BUF_INTERVALS (current_buffer);
2124 #endif /* USE_TEXT_PROPERTIES */
2126 validate_region (&startr1, &endr1);
2127 validate_region (&startr2, &endr2);
2129 start1 = XFASTINT (startr1);
2130 end1 = XFASTINT (endr1);
2131 start2 = XFASTINT (startr2);
2132 end2 = XFASTINT (endr2);
2133 gap = GPT;
2135 /* Swap the regions if they're reversed. */
2136 if (start2 < end1)
2138 register int glumph = start1;
2139 start1 = start2;
2140 start2 = glumph;
2141 glumph = end1;
2142 end1 = end2;
2143 end2 = glumph;
2146 len1 = end1 - start1;
2147 len2 = end2 - start2;
2149 if (start2 < end1)
2150 error ("transposed regions not properly ordered");
2151 else if (start1 == end1 || start2 == end2)
2152 error ("transposed region may not be of length 0");
2154 /* The possibilities are:
2155 1. Adjacent (contiguous) regions, or separate but equal regions
2156 (no, really equal, in this case!), or
2157 2. Separate regions of unequal size.
2159 The worst case is usually No. 2. It means that (aside from
2160 potential need for getting the gap out of the way), there also
2161 needs to be a shifting of the text between the two regions. So
2162 if they are spread far apart, we are that much slower... sigh. */
2164 /* It must be pointed out that the really studly thing to do would
2165 be not to move the gap at all, but to leave it in place and work
2166 around it if necessary. This would be extremely efficient,
2167 especially considering that people are likely to do
2168 transpositions near where they are working interactively, which
2169 is exactly where the gap would be found. However, such code
2170 would be much harder to write and to read. So, if you are
2171 reading this comment and are feeling squirrely, by all means have
2172 a go! I just didn't feel like doing it, so I will simply move
2173 the gap the minimum distance to get it out of the way, and then
2174 deal with an unbroken array. */
2176 /* Make sure the gap won't interfere, by moving it out of the text
2177 we will operate on. */
2178 if (start1 < gap && gap < end2)
2180 if (gap - start1 < end2 - gap)
2181 move_gap (start1);
2182 else
2183 move_gap (end2);
2186 /* Hmmm... how about checking to see if the gap is large
2187 enough to use as the temporary storage? That would avoid an
2188 allocation... interesting. Later, don't fool with it now. */
2190 /* Working without memmove, for portability (sigh), so must be
2191 careful of overlapping subsections of the array... */
2193 if (end1 == start2) /* adjacent regions */
2195 modify_region (current_buffer, start1, end2);
2196 record_change (start1, len1 + len2);
2198 #ifdef USE_TEXT_PROPERTIES
2199 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2200 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
2201 Fset_text_properties (start1, end2, Qnil, Qnil);
2202 #endif /* USE_TEXT_PROPERTIES */
2204 /* First region smaller than second. */
2205 if (len1 < len2)
2207 /* We use alloca only if it is small,
2208 because we want to avoid stack overflow. */
2209 if (len2 > 20000)
2210 temp = (unsigned char *) xmalloc (len2);
2211 else
2212 temp = (unsigned char *) alloca (len2);
2214 /* Don't precompute these addresses. We have to compute them
2215 at the last minute, because the relocating allocator might
2216 have moved the buffer around during the xmalloc. */
2217 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1);
2218 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2);
2220 bcopy (start2_addr, temp, len2);
2221 bcopy (start1_addr, start1_addr + len2, len1);
2222 bcopy (temp, start1_addr, len2);
2223 if (len2 > 20000)
2224 free (temp);
2226 else
2227 /* First region not smaller than second. */
2229 if (len1 > 20000)
2230 temp = (unsigned char *) xmalloc (len1);
2231 else
2232 temp = (unsigned char *) alloca (len1);
2233 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1);
2234 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2);
2235 bcopy (start1_addr, temp, len1);
2236 bcopy (start2_addr, start1_addr, len2);
2237 bcopy (temp, start1_addr + len2, len1);
2238 if (len1 > 20000)
2239 free (temp);
2241 #ifdef USE_TEXT_PROPERTIES
2242 graft_intervals_into_buffer (tmp_interval1, start1 + len2,
2243 len1, current_buffer, 0);
2244 graft_intervals_into_buffer (tmp_interval2, start1,
2245 len2, current_buffer, 0);
2246 #endif /* USE_TEXT_PROPERTIES */
2248 /* Non-adjacent regions, because end1 != start2, bleagh... */
2249 else
2251 if (len1 == len2)
2252 /* Regions are same size, though, how nice. */
2254 modify_region (current_buffer, start1, end1);
2255 modify_region (current_buffer, start2, end2);
2256 record_change (start1, len1);
2257 record_change (start2, len2);
2258 #ifdef USE_TEXT_PROPERTIES
2259 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2260 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
2261 Fset_text_properties (start1, end1, Qnil, Qnil);
2262 Fset_text_properties (start2, end2, Qnil, Qnil);
2263 #endif /* USE_TEXT_PROPERTIES */
2265 if (len1 > 20000)
2266 temp = (unsigned char *) xmalloc (len1);
2267 else
2268 temp = (unsigned char *) alloca (len1);
2269 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1);
2270 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2);
2271 bcopy (start1_addr, temp, len1);
2272 bcopy (start2_addr, start1_addr, len2);
2273 bcopy (temp, start2_addr, len1);
2274 if (len1 > 20000)
2275 free (temp);
2276 #ifdef USE_TEXT_PROPERTIES
2277 graft_intervals_into_buffer (tmp_interval1, start2,
2278 len1, current_buffer, 0);
2279 graft_intervals_into_buffer (tmp_interval2, start1,
2280 len2, current_buffer, 0);
2281 #endif /* USE_TEXT_PROPERTIES */
2284 else if (len1 < len2) /* Second region larger than first */
2285 /* Non-adjacent & unequal size, area between must also be shifted. */
2287 len_mid = start2 - end1;
2288 modify_region (current_buffer, start1, end2);
2289 record_change (start1, (end2 - start1));
2290 #ifdef USE_TEXT_PROPERTIES
2291 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2292 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
2293 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
2294 Fset_text_properties (start1, end2, Qnil, Qnil);
2295 #endif /* USE_TEXT_PROPERTIES */
2297 /* holds region 2 */
2298 if (len2 > 20000)
2299 temp = (unsigned char *) xmalloc (len2);
2300 else
2301 temp = (unsigned char *) alloca (len2);
2302 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1);
2303 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2);
2304 bcopy (start2_addr, temp, len2);
2305 bcopy (start1_addr, start1_addr + len_mid + len2, len1);
2306 safe_bcopy (start1_addr + len1, start1_addr + len2, len_mid);
2307 bcopy (temp, start1_addr, len2);
2308 if (len2 > 20000)
2309 free (temp);
2310 #ifdef USE_TEXT_PROPERTIES
2311 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
2312 len1, current_buffer, 0);
2313 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
2314 len_mid, current_buffer, 0);
2315 graft_intervals_into_buffer (tmp_interval2, start1,
2316 len2, current_buffer, 0);
2317 #endif /* USE_TEXT_PROPERTIES */
2319 else
2320 /* Second region smaller than first. */
2322 len_mid = start2 - end1;
2323 record_change (start1, (end2 - start1));
2324 modify_region (current_buffer, start1, end2);
2326 #ifdef USE_TEXT_PROPERTIES
2327 tmp_interval1 = copy_intervals (cur_intv, start1, len1);
2328 tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
2329 tmp_interval2 = copy_intervals (cur_intv, start2, len2);
2330 Fset_text_properties (start1, end2, Qnil, Qnil);
2331 #endif /* USE_TEXT_PROPERTIES */
2333 /* holds region 1 */
2334 if (len1 > 20000)
2335 temp = (unsigned char *) xmalloc (len1);
2336 else
2337 temp = (unsigned char *) alloca (len1);
2338 start1_addr = BUF_CHAR_ADDRESS (current_buffer, start1);
2339 start2_addr = BUF_CHAR_ADDRESS (current_buffer, start2);
2340 bcopy (start1_addr, temp, len1);
2341 bcopy (start2_addr, start1_addr, len2);
2342 bcopy (start1_addr + len1, start1_addr + len2, len_mid);
2343 bcopy (temp, start1_addr + len2 + len_mid, len1);
2344 if (len1 > 20000)
2345 free (temp);
2346 #ifdef USE_TEXT_PROPERTIES
2347 graft_intervals_into_buffer (tmp_interval1, end2 - len1,
2348 len1, current_buffer, 0);
2349 graft_intervals_into_buffer (tmp_interval_mid, start1 + len2,
2350 len_mid, current_buffer, 0);
2351 graft_intervals_into_buffer (tmp_interval2, start1,
2352 len2, current_buffer, 0);
2353 #endif /* USE_TEXT_PROPERTIES */
2357 /* todo: this will be slow, because for every transposition, we
2358 traverse the whole friggin marker list. Possible solutions:
2359 somehow get a list of *all* the markers across multiple
2360 transpositions and do it all in one swell phoop. Or maybe modify
2361 Emacs' marker code to keep an ordered list or tree. This might
2362 be nicer, and more beneficial in the long run, but would be a
2363 bunch of work. Plus the way they're arranged now is nice. */
2364 if (NILP (leave_markers))
2366 transpose_markers (start1, end1, start2, end2);
2367 fix_overlays_in_range (start1, end2);
2370 return Qnil;
2374 void
2375 syms_of_editfns ()
2377 environbuf = 0;
2379 Qbuffer_access_fontify_functions
2380 = intern ("buffer-access-fontify-functions");
2381 staticpro (&Qbuffer_access_fontify_functions);
2383 DEFVAR_LISP ("buffer-access-fontify-functions",
2384 &Vbuffer_access_fontify_functions,
2385 "List of functions called by `buffer-substring' to fontify if necessary.\n\
2386 Each function is called with two arguments which specify the range\n\
2387 of the buffer being accessed.");
2388 Vbuffer_access_fontify_functions = Qnil;
2391 Lisp_Object obuf;
2392 extern Lisp_Object Vprin1_to_string_buffer;
2393 obuf = Fcurrent_buffer ();
2394 /* Do this here, because init_buffer_once is too early--it won't work. */
2395 Fset_buffer (Vprin1_to_string_buffer);
2396 /* Make sure buffer-access-fontify-functions is nil in this buffer. */
2397 Fset (Fmake_local_variable (intern ("buffer-access-fontify-functions")),
2398 Qnil);
2399 Fset_buffer (obuf);
2402 DEFVAR_LISP ("buffer-access-fontified-property",
2403 &Vbuffer_access_fontified_property,
2404 "Property which (if non-nil) indicates text has been fontified.\n\
2405 `buffer-substring' need not call the `buffer-access-fontify-functions'\n\
2406 functions if all the text being accessed has this property.");
2407 Vbuffer_access_fontified_property = Qnil;
2409 DEFVAR_LISP ("system-name", &Vsystem_name,
2410 "The name of the machine Emacs is running on.");
2412 DEFVAR_LISP ("user-full-name", &Vuser_full_name,
2413 "The full name of the user logged in.");
2415 DEFVAR_LISP ("user-login-name", &Vuser_login_name,
2416 "The user's name, taken from environment variables if possible.");
2418 DEFVAR_LISP ("user-real-login-name", &Vuser_real_login_name,
2419 "The user's name, based upon the real uid only.");
2421 defsubr (&Schar_equal);
2422 defsubr (&Sgoto_char);
2423 defsubr (&Sstring_to_char);
2424 defsubr (&Schar_to_string);
2425 defsubr (&Sbuffer_substring);
2426 defsubr (&Sbuffer_substring_no_properties);
2427 defsubr (&Sbuffer_string);
2429 defsubr (&Spoint_marker);
2430 defsubr (&Smark_marker);
2431 defsubr (&Spoint);
2432 defsubr (&Sregion_beginning);
2433 defsubr (&Sregion_end);
2434 /* defsubr (&Smark); */
2435 /* defsubr (&Sset_mark); */
2436 defsubr (&Ssave_excursion);
2438 defsubr (&Sbufsize);
2439 defsubr (&Spoint_max);
2440 defsubr (&Spoint_min);
2441 defsubr (&Spoint_min_marker);
2442 defsubr (&Spoint_max_marker);
2444 defsubr (&Sbobp);
2445 defsubr (&Seobp);
2446 defsubr (&Sbolp);
2447 defsubr (&Seolp);
2448 defsubr (&Sfollowing_char);
2449 defsubr (&Sprevious_char);
2450 defsubr (&Schar_after);
2451 defsubr (&Sinsert);
2452 defsubr (&Sinsert_before_markers);
2453 defsubr (&Sinsert_and_inherit);
2454 defsubr (&Sinsert_and_inherit_before_markers);
2455 defsubr (&Sinsert_char);
2457 defsubr (&Suser_login_name);
2458 defsubr (&Suser_real_login_name);
2459 defsubr (&Suser_uid);
2460 defsubr (&Suser_real_uid);
2461 defsubr (&Suser_full_name);
2462 defsubr (&Semacs_pid);
2463 defsubr (&Scurrent_time);
2464 defsubr (&Sformat_time_string);
2465 defsubr (&Sdecode_time);
2466 defsubr (&Sencode_time);
2467 defsubr (&Scurrent_time_string);
2468 defsubr (&Scurrent_time_zone);
2469 defsubr (&Sset_time_zone_rule);
2470 defsubr (&Ssystem_name);
2471 defsubr (&Smessage);
2472 defsubr (&Smessage_box);
2473 defsubr (&Smessage_or_box);
2474 defsubr (&Sformat);
2476 defsubr (&Sinsert_buffer_substring);
2477 defsubr (&Scompare_buffer_substrings);
2478 defsubr (&Ssubst_char_in_region);
2479 defsubr (&Stranslate_region);
2480 defsubr (&Sdelete_region);
2481 defsubr (&Swiden);
2482 defsubr (&Snarrow_to_region);
2483 defsubr (&Ssave_restriction);
2484 defsubr (&Stranspose_regions);