(Finsert_and_inherit): New function.
[bpt/emacs.git] / src / editfns.c
1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985, 1986, 1987, 1989, 1993 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
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)
9 any later version.
10
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.
15
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. */
19
20
21 #include <sys/types.h>
22
23 #include <config.h>
24
25 #ifdef VMS
26 #include "vms-pwd.h"
27 #else
28 #include <pwd.h>
29 #endif
30
31 #include "lisp.h"
32 #include "intervals.h"
33 #include "buffer.h"
34 #include "window.h"
35
36 #include "systime.h"
37
38 #define min(a, b) ((a) < (b) ? (a) : (b))
39 #define max(a, b) ((a) > (b) ? (a) : (b))
40
41 /* Some static data, and a function to initialize it for each run */
42
43 Lisp_Object Vsystem_name;
44 Lisp_Object Vuser_real_name; /* login name of current user ID */
45 Lisp_Object Vuser_full_name; /* full name of current user */
46 Lisp_Object Vuser_name; /* user name from USER or LOGNAME. */
47
48 void
49 init_editfns ()
50 {
51 char *user_name;
52 register unsigned char *p, *q, *r;
53 struct passwd *pw; /* password entry for the current user */
54 extern char *index ();
55 Lisp_Object tem;
56
57 /* Set up system_name even when dumping. */
58
59 Vsystem_name = build_string (get_system_name ());
60 p = XSTRING (Vsystem_name)->data;
61 while (*p)
62 {
63 if (*p == ' ' || *p == '\t')
64 *p = '-';
65 p++;
66 }
67
68 #ifndef CANNOT_DUMP
69 /* Don't bother with this on initial start when just dumping out */
70 if (!initialized)
71 return;
72 #endif /* not CANNOT_DUMP */
73
74 pw = (struct passwd *) getpwuid (getuid ());
75 Vuser_real_name = build_string (pw ? pw->pw_name : "unknown");
76
77 /* Get the effective user name, by consulting environment variables,
78 or the effective uid if those are unset. */
79 user_name = (char *) getenv ("USER");
80 if (!user_name)
81 user_name = (char *) getenv ("LOGNAME");
82 if (!user_name)
83 {
84 pw = (struct passwd *) getpwuid (geteuid ());
85 user_name = (char *) (pw ? pw->pw_name : "unknown");
86 }
87 Vuser_name = build_string (user_name);
88
89 /* If the user name claimed in the environment vars differs from
90 the real uid, use the claimed name to find the full name. */
91 tem = Fstring_equal (Vuser_name, Vuser_real_name);
92 if (NILP (tem))
93 pw = (struct passwd *) getpwnam (XSTRING (Vuser_name)->data);
94
95 p = (unsigned char *) (pw ? USER_FULL_NAME : "unknown");
96 q = (unsigned char *) index (p, ',');
97 Vuser_full_name = make_string (p, q ? q - p : strlen (p));
98
99 #ifdef AMPERSAND_FULL_NAME
100 p = XSTRING (Vuser_full_name)->data;
101 q = (char *) index (p, '&');
102 /* Substitute the login name for the &, upcasing the first character. */
103 if (q)
104 {
105 r = (char *) alloca (strlen (p) + XSTRING (Vuser_name)->size + 1);
106 bcopy (p, r, q - p);
107 r[q - p] = 0;
108 strcat (r, XSTRING (Vuser_name)->data);
109 r[q - p] = UPCASE (r[q - p]);
110 strcat (r, q + 1);
111 Vuser_full_name = build_string (r);
112 }
113 #endif /* AMPERSAND_FULL_NAME */
114 }
115 \f
116 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0,
117 "Convert arg CHAR to a one-character string containing that character.")
118 (n)
119 Lisp_Object n;
120 {
121 char c;
122 CHECK_NUMBER (n, 0);
123
124 c = XINT (n);
125 return make_string (&c, 1);
126 }
127
128 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0,
129 "Convert arg STRING to a character, the first character of that string.")
130 (str)
131 register Lisp_Object str;
132 {
133 register Lisp_Object val;
134 register struct Lisp_String *p;
135 CHECK_STRING (str, 0);
136
137 p = XSTRING (str);
138 if (p->size)
139 XFASTINT (val) = ((unsigned char *) p->data)[0];
140 else
141 XFASTINT (val) = 0;
142 return val;
143 }
144 \f
145 static Lisp_Object
146 buildmark (val)
147 int val;
148 {
149 register Lisp_Object mark;
150 mark = Fmake_marker ();
151 Fset_marker (mark, make_number (val), Qnil);
152 return mark;
153 }
154
155 DEFUN ("point", Fpoint, Spoint, 0, 0, 0,
156 "Return value of point, as an integer.\n\
157 Beginning of buffer is position (point-min)")
158 ()
159 {
160 Lisp_Object temp;
161 XFASTINT (temp) = point;
162 return temp;
163 }
164
165 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 0, 0,
166 "Return value of point, as a marker object.")
167 ()
168 {
169 return buildmark (point);
170 }
171
172 int
173 clip_to_bounds (lower, num, upper)
174 int lower, num, upper;
175 {
176 if (num < lower)
177 return lower;
178 else if (num > upper)
179 return upper;
180 else
181 return num;
182 }
183
184 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 1, "NGoto char: ",
185 "Set point to POSITION, a number or marker.\n\
186 Beginning of buffer is position (point-min), end is (point-max).")
187 (n)
188 register Lisp_Object n;
189 {
190 CHECK_NUMBER_COERCE_MARKER (n, 0);
191
192 SET_PT (clip_to_bounds (BEGV, XINT (n), ZV));
193 return n;
194 }
195
196 static Lisp_Object
197 region_limit (beginningp)
198 int beginningp;
199 {
200 extern Lisp_Object Vmark_even_if_inactive; /* Defined in callint.c. */
201 register Lisp_Object m;
202 if (!NILP (Vtransient_mark_mode) && NILP (Vmark_even_if_inactive)
203 && NILP (current_buffer->mark_active))
204 Fsignal (Qmark_inactive, Qnil);
205 m = Fmarker_position (current_buffer->mark);
206 if (NILP (m)) error ("There is no region now");
207 if ((point < XFASTINT (m)) == beginningp)
208 return (make_number (point));
209 else
210 return (m);
211 }
212
213 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 0, 0,
214 "Return position of beginning of region, as an integer.")
215 ()
216 {
217 return (region_limit (1));
218 }
219
220 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 0, 0,
221 "Return position of end of region, as an integer.")
222 ()
223 {
224 return (region_limit (0));
225 }
226
227 #if 0 /* now in lisp code */
228 DEFUN ("mark", Fmark, Smark, 0, 0, 0,
229 "Return this buffer's mark value as integer, or nil if no mark.\n\
230 If you are using this in an editing command, you are most likely making\n\
231 a mistake; see the documentation of `set-mark'.")
232 ()
233 {
234 return Fmarker_position (current_buffer->mark);
235 }
236 #endif /* commented out code */
237
238 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 0, 0,
239 "Return this buffer's mark, as a marker object.\n\
240 Watch out! Moving this marker changes the mark position.\n\
241 If you set the marker not to point anywhere, the buffer will have no mark.")
242 ()
243 {
244 return current_buffer->mark;
245 }
246
247 #if 0 /* this is now in lisp code */
248 DEFUN ("set-mark", Fset_mark, Sset_mark, 1, 1, 0,
249 "Set this buffer's mark to POS. Don't use this function!\n\
250 That is to say, don't use this function unless you want\n\
251 the user to see that the mark has moved, and you want the previous\n\
252 mark position to be lost.\n\
253 \n\
254 Normally, when a new mark is set, the old one should go on the stack.\n\
255 This is why most applications should use push-mark, not set-mark.\n\
256 \n\
257 Novice programmers often try to use the mark for the wrong purposes.\n\
258 The mark saves a location for the user's convenience.\n\
259 Most editing commands should not alter the mark.\n\
260 To remember a location for internal use in the Lisp program,\n\
261 store it in a Lisp variable. Example:\n\
262 \n\
263 (let ((beg (point))) (forward-line 1) (delete-region beg (point))).")
264 (pos)
265 Lisp_Object pos;
266 {
267 if (NILP (pos))
268 {
269 current_buffer->mark = Qnil;
270 return Qnil;
271 }
272 CHECK_NUMBER_COERCE_MARKER (pos, 0);
273
274 if (NILP (current_buffer->mark))
275 current_buffer->mark = Fmake_marker ();
276
277 Fset_marker (current_buffer->mark, pos, Qnil);
278 return pos;
279 }
280 #endif /* commented-out code */
281
282 Lisp_Object
283 save_excursion_save ()
284 {
285 register int visible = (XBUFFER (XWINDOW (selected_window)->buffer)
286 == current_buffer);
287
288 return Fcons (Fpoint_marker (),
289 Fcons (Fcopy_marker (current_buffer->mark),
290 Fcons (visible ? Qt : Qnil,
291 current_buffer->mark_active)));
292 }
293
294 Lisp_Object
295 save_excursion_restore (info)
296 register Lisp_Object info;
297 {
298 register Lisp_Object tem, tem1;
299
300 tem = Fmarker_buffer (Fcar (info));
301 /* If buffer being returned to is now deleted, avoid error */
302 /* Otherwise could get error here while unwinding to top level
303 and crash */
304 /* In that case, Fmarker_buffer returns nil now. */
305 if (NILP (tem))
306 return Qnil;
307 Fset_buffer (tem);
308 tem = Fcar (info);
309 Fgoto_char (tem);
310 unchain_marker (tem);
311 tem = Fcar (Fcdr (info));
312 Fset_marker (current_buffer->mark, tem, Fcurrent_buffer ());
313 unchain_marker (tem);
314 tem = Fcdr (Fcdr (info));
315 #if 0 /* We used to make the current buffer visible in the selected window
316 if that was true previously. That avoids some anomalies.
317 But it creates others, and it wasn't documented, and it is simpler
318 and cleaner never to alter the window/buffer connections. */
319 tem1 = Fcar (tem);
320 if (!NILP (tem1)
321 && current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))
322 Fswitch_to_buffer (Fcurrent_buffer (), Qnil);
323 #endif /* 0 */
324
325 tem1 = current_buffer->mark_active;
326 current_buffer->mark_active = Fcdr (tem);
327 if (! NILP (current_buffer->mark_active))
328 call1 (Vrun_hooks, intern ("activate-mark-hook"));
329 else if (! NILP (tem1))
330 call1 (Vrun_hooks, intern ("deactivate-mark-hook"));
331 return Qnil;
332 }
333
334 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0,
335 "Save point, mark, and current buffer; execute BODY; restore those things.\n\
336 Executes BODY just like `progn'.\n\
337 The values of point, mark and the current buffer are restored\n\
338 even in case of abnormal exit (throw or error).\n\
339 The state of activation of the mark is also restored.")
340 (args)
341 Lisp_Object args;
342 {
343 register Lisp_Object val;
344 int count = specpdl_ptr - specpdl;
345
346 record_unwind_protect (save_excursion_restore, save_excursion_save ());
347
348 val = Fprogn (args);
349 return unbind_to (count, val);
350 }
351 \f
352 DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 0, 0,
353 "Return the number of characters in the current buffer.")
354 ()
355 {
356 Lisp_Object temp;
357 XFASTINT (temp) = Z - BEG;
358 return temp;
359 }
360
361 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 0, 0,
362 "Return the minimum permissible value of point in the current buffer.\n\
363 This is 1, unless a clipping restriction is in effect.")
364 ()
365 {
366 Lisp_Object temp;
367 XFASTINT (temp) = BEGV;
368 return temp;
369 }
370
371 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 0, 0,
372 "Return a marker to the minimum permissible value of point in this buffer.\n\
373 This is the beginning, unless a clipping restriction is in effect.")
374 ()
375 {
376 return buildmark (BEGV);
377 }
378
379 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 0, 0,
380 "Return the maximum permissible value of point in the current buffer.\n\
381 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
382 in which case it is less.")
383 ()
384 {
385 Lisp_Object temp;
386 XFASTINT (temp) = ZV;
387 return temp;
388 }
389
390 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 0, 0,
391 "Return a marker to the maximum permissible value of point in this buffer.\n\
392 This is (1+ (buffer-size)), unless a clipping restriction is in effect,\n\
393 in which case it is less.")
394 ()
395 {
396 return buildmark (ZV);
397 }
398
399 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 0, 0,
400 "Return the character following point, as a number.\n\
401 At the end of the buffer or accessible region, return 0.")
402 ()
403 {
404 Lisp_Object temp;
405 if (point >= ZV)
406 XFASTINT (temp) = 0;
407 else
408 XFASTINT (temp) = FETCH_CHAR (point);
409 return temp;
410 }
411
412 DEFUN ("preceding-char", Fprevious_char, Sprevious_char, 0, 0, 0,
413 "Return the character preceding point, as a number.\n\
414 At the beginning of the buffer or accessible region, return 0.")
415 ()
416 {
417 Lisp_Object temp;
418 if (point <= BEGV)
419 XFASTINT (temp) = 0;
420 else
421 XFASTINT (temp) = FETCH_CHAR (point - 1);
422 return temp;
423 }
424
425 DEFUN ("bobp", Fbobp, Sbobp, 0, 0, 0,
426 "Return T if point is at the beginning of the buffer.\n\
427 If the buffer is narrowed, this means the beginning of the narrowed part.")
428 ()
429 {
430 if (point == BEGV)
431 return Qt;
432 return Qnil;
433 }
434
435 DEFUN ("eobp", Feobp, Seobp, 0, 0, 0,
436 "Return T if point is at the end of the buffer.\n\
437 If the buffer is narrowed, this means the end of the narrowed part.")
438 ()
439 {
440 if (point == ZV)
441 return Qt;
442 return Qnil;
443 }
444
445 DEFUN ("bolp", Fbolp, Sbolp, 0, 0, 0,
446 "Return T if point is at the beginning of a line.")
447 ()
448 {
449 if (point == BEGV || FETCH_CHAR (point - 1) == '\n')
450 return Qt;
451 return Qnil;
452 }
453
454 DEFUN ("eolp", Feolp, Seolp, 0, 0, 0,
455 "Return T if point is at the end of a line.\n\
456 `End of a line' includes point being at the end of the buffer.")
457 ()
458 {
459 if (point == ZV || FETCH_CHAR (point) == '\n')
460 return Qt;
461 return Qnil;
462 }
463
464 DEFUN ("char-after", Fchar_after, Schar_after, 1, 1, 0,
465 "Return character in current buffer at position POS.\n\
466 POS is an integer or a buffer pointer.\n\
467 If POS is out of range, the value is nil.")
468 (pos)
469 Lisp_Object pos;
470 {
471 register Lisp_Object val;
472 register int n;
473
474 CHECK_NUMBER_COERCE_MARKER (pos, 0);
475
476 n = XINT (pos);
477 if (n < BEGV || n >= ZV) return Qnil;
478
479 XFASTINT (val) = FETCH_CHAR (n);
480 return val;
481 }
482 \f
483 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 0, 0,
484 "Return the name under which the user logged in, as a string.\n\
485 This is based on the effective uid, not the real uid.\n\
486 Also, if the environment variable USER or LOGNAME is set,\n\
487 that determines the value of this function.")
488 ()
489 {
490 return Vuser_name;
491 }
492
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 Differs from `user-login-name' when running under `su'.")
497 ()
498 {
499 return Vuser_real_name;
500 }
501
502 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0,
503 "Return the effective uid of Emacs, as an integer.")
504 ()
505 {
506 return make_number (geteuid ());
507 }
508
509 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0,
510 "Return the real uid of Emacs, as an integer.")
511 ()
512 {
513 return make_number (getuid ());
514 }
515
516 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 0, 0,
517 "Return the full name of the user logged in, as a string.")
518 ()
519 {
520 return Vuser_full_name;
521 }
522
523 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0,
524 "Return the name of the machine you are running on, as a string.")
525 ()
526 {
527 return Vsystem_name;
528 }
529
530 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0,
531 "Return the current time, as the number of seconds since 12:00 AM January 1970.\n\
532 The time is returned as a list of three integers. The first has the\n\
533 most significant 16 bits of the seconds, while the second has the\n\
534 least significant 16 bits. The third integer gives the microsecond\n\
535 count.\n\
536 \n\
537 The microsecond count is zero on systems that do not provide\n\
538 resolution finer than a second.")
539 ()
540 {
541 EMACS_TIME t;
542 Lisp_Object result[3];
543
544 EMACS_GET_TIME (t);
545 XSET (result[0], Lisp_Int, (EMACS_SECS (t) >> 16) & 0xffff);
546 XSET (result[1], Lisp_Int, (EMACS_SECS (t) >> 0) & 0xffff);
547 XSET (result[2], Lisp_Int, EMACS_USECS (t));
548
549 return Flist (3, result);
550 }
551 \f
552
553 static int
554 lisp_time_argument (specified_time, result)
555 Lisp_Object specified_time;
556 time_t *result;
557 {
558 if (NILP (specified_time))
559 return time (result) != -1;
560 else
561 {
562 Lisp_Object high, low;
563 high = Fcar (specified_time);
564 CHECK_NUMBER (high, 0);
565 low = Fcdr (specified_time);
566 if (XTYPE (low) == Lisp_Cons)
567 low = Fcar (low);
568 CHECK_NUMBER (low, 0);
569 *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
570 return *result >> 16 == XINT (high);
571 }
572 }
573
574 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string, 0, 1, 0,
575 "Return the current time, as a human-readable string.\n\
576 Programs can use this function to decode a time,\n\
577 since the number of columns in each field is fixed.\n\
578 The format is `Sun Sep 16 01:03:52 1973'.\n\
579 If an argument is given, it specifies a time to format\n\
580 instead of the current time. The argument should have the form:\n\
581 (HIGH . LOW)\n\
582 or the form:\n\
583 (HIGH LOW . IGNORED).\n\
584 Thus, you can use times obtained from `current-time'\n\
585 and from `file-attributes'.")
586 (specified_time)
587 Lisp_Object specified_time;
588 {
589 time_t value;
590 char buf[30];
591 register char *tem;
592
593 if (! lisp_time_argument (specified_time, &value))
594 value = -1;
595 tem = (char *) ctime (&value);
596
597 strncpy (buf, tem, 24);
598 buf[24] = 0;
599
600 return build_string (buf);
601 }
602
603 #define TM_YEAR_ORIGIN 1900
604
605 /* Yield A - B, measured in seconds. */
606 static long
607 difftm(a, b)
608 struct tm *a, *b;
609 {
610 int ay = a->tm_year + (TM_YEAR_ORIGIN - 1);
611 int by = b->tm_year + (TM_YEAR_ORIGIN - 1);
612 return
613 (
614 (
615 (
616 /* difference in day of year */
617 a->tm_yday - b->tm_yday
618 /* + intervening leap days */
619 + ((ay >> 2) - (by >> 2))
620 - (ay/100 - by/100)
621 + ((ay/100 >> 2) - (by/100 >> 2))
622 /* + difference in years * 365 */
623 + (long)(ay-by) * 365
624 )*24 + (a->tm_hour - b->tm_hour)
625 )*60 + (a->tm_min - b->tm_min)
626 )*60 + (a->tm_sec - b->tm_sec);
627 }
628
629 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0,
630 "Return the offset and name for the local time zone.\n\
631 This returns a list of the form (OFFSET NAME).\n\
632 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).\n\
633 A negative value means west of Greenwich.\n\
634 NAME is a string giving the name of the time zone.\n\
635 If an argument is given, it specifies when the time zone offset is determined\n\
636 instead of using the current time. The argument should have the form:\n\
637 (HIGH . LOW)\n\
638 or the form:\n\
639 (HIGH LOW . IGNORED).\n\
640 Thus, you can use times obtained from `current-time'\n\
641 and from `file-attributes'.\n\
642 \n\
643 Some operating systems cannot provide all this information to Emacs;\n\
644 in this case, `current-time-zone' returns a list containing nil for\n\
645 the data it can't find.")
646 (specified_time)
647 Lisp_Object specified_time;
648 {
649 time_t value;
650 struct tm *t;
651
652 if (lisp_time_argument (specified_time, &value)
653 && (t = gmtime (&value)) != 0)
654 {
655 struct tm gmt;
656 long offset;
657 char *s, buf[6];
658
659 gmt = *t; /* Make a copy, in case localtime modifies *t. */
660 t = localtime (&value);
661 offset = difftm (t, &gmt);
662 s = 0;
663 #ifdef HAVE_TM_ZONE
664 if (t->tm_zone)
665 s = t->tm_zone;
666 #else /* not HAVE_TM_ZONE */
667 #ifdef HAVE_TZNAME
668 if (t->tm_isdst == 0 || t->tm_isdst == 1)
669 s = tzname[t->tm_isdst];
670 #endif
671 #endif /* not HAVE_TM_ZONE */
672 if (!s)
673 {
674 /* No local time zone name is available; use "+-NNNN" instead. */
675 int am = (offset < 0 ? -offset : offset) / 60;
676 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
677 s = buf;
678 }
679 return Fcons (make_number (offset), Fcons (build_string (s), Qnil));
680 }
681 else
682 return Fmake_list (2, Qnil);
683 }
684
685 \f
686 void
687 insert1 (arg)
688 Lisp_Object arg;
689 {
690 Finsert (1, &arg);
691 }
692
693
694 /* Callers passing one argument to Finsert need not gcpro the
695 argument "array", since the only element of the array will
696 not be used after calling insert or insert_from_string, so
697 we don't care if it gets trashed. */
698
699 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0,
700 "Insert the arguments, either strings or characters, at point.\n\
701 Point moves forward so that it ends up after the inserted text.\n\
702 Any other markers at the point of insertion remain before the text.")
703 (nargs, args)
704 int nargs;
705 register Lisp_Object *args;
706 {
707 register int argnum;
708 register Lisp_Object tem;
709 char str[1];
710
711 for (argnum = 0; argnum < nargs; argnum++)
712 {
713 tem = args[argnum];
714 retry:
715 if (XTYPE (tem) == Lisp_Int)
716 {
717 str[0] = XINT (tem);
718 insert (str, 1);
719 }
720 else if (XTYPE (tem) == Lisp_String)
721 {
722 insert_from_string (tem, 0, XSTRING (tem)->size, 0);
723 }
724 else
725 {
726 tem = wrong_type_argument (Qchar_or_string_p, tem);
727 goto retry;
728 }
729 }
730
731 return Qnil;
732 }
733
734 DEFUN ("insert-and-inherit", Finsert_and_inherit, Sinsert_and_inherit,
735 0, MANY, 0,
736 "Insert the arguments at point, inheriting properties from adjoining text.\n\
737 Point moves forward so that it ends up after the inserted text.\n\
738 Any other markers at the point of insertion remain before the text.")
739 (nargs, args)
740 int nargs;
741 register Lisp_Object *args;
742 {
743 register int argnum;
744 register Lisp_Object tem;
745 char str[1];
746
747 for (argnum = 0; argnum < nargs; argnum++)
748 {
749 tem = args[argnum];
750 retry:
751 if (XTYPE (tem) == Lisp_Int)
752 {
753 str[0] = XINT (tem);
754 insert (str, 1);
755 }
756 else if (XTYPE (tem) == Lisp_String)
757 {
758 insert_from_string (tem, 0, XSTRING (tem)->size, 1);
759 }
760 else
761 {
762 tem = wrong_type_argument (Qchar_or_string_p, tem);
763 goto retry;
764 }
765 }
766
767 return Qnil;
768 }
769
770 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0,
771 "Insert strings or characters at point, relocating markers after the text.\n\
772 Point moves forward so that it ends up after the inserted text.\n\
773 Any other markers at the point of insertion also end up after the text.")
774 (nargs, args)
775 int nargs;
776 register Lisp_Object *args;
777 {
778 register int argnum;
779 register Lisp_Object tem;
780 char str[1];
781
782 for (argnum = 0; argnum < nargs; argnum++)
783 {
784 tem = args[argnum];
785 retry:
786 if (XTYPE (tem) == Lisp_Int)
787 {
788 str[0] = XINT (tem);
789 insert_before_markers (str, 1);
790 }
791 else if (XTYPE (tem) == Lisp_String)
792 {
793 insert_from_string_before_markers (tem, 0, XSTRING (tem)->size, 0);
794 }
795 else
796 {
797 tem = wrong_type_argument (Qchar_or_string_p, tem);
798 goto retry;
799 }
800 }
801
802 return Qnil;
803 }
804
805 DEFUN ("insert-before-markers-and-inherit",
806 Finsert_and_inherit_before_markers, Sinsert_and_inherit_before_markers,
807 0, MANY, 0,
808 "Insert text at point, relocating markers and inheriting properties.\n\
809 Point moves forward so that it ends up after the inserted text.\n\
810 Any other markers at the point of insertion also end up after the text.")
811 (nargs, args)
812 int nargs;
813 register Lisp_Object *args;
814 {
815 register int argnum;
816 register Lisp_Object tem;
817 char str[1];
818
819 for (argnum = 0; argnum < nargs; argnum++)
820 {
821 tem = args[argnum];
822 retry:
823 if (XTYPE (tem) == Lisp_Int)
824 {
825 str[0] = XINT (tem);
826 insert_before_markers (str, 1);
827 }
828 else if (XTYPE (tem) == Lisp_String)
829 {
830 insert_from_string_before_markers (tem, 0, XSTRING (tem)->size, 1);
831 }
832 else
833 {
834 tem = wrong_type_argument (Qchar_or_string_p, tem);
835 goto retry;
836 }
837 }
838
839 return Qnil;
840 }
841 \f
842 DEFUN ("insert-char", Finsert_char, Sinsert_char, 2, 2, 0,
843 "Insert COUNT (second arg) copies of CHAR (first arg).\n\
844 Point and all markers are affected as in the function `insert'.\n\
845 Both arguments are required.")
846 (chr, count)
847 Lisp_Object chr, count;
848 {
849 register unsigned char *string;
850 register int strlen;
851 register int i, n;
852
853 CHECK_NUMBER (chr, 0);
854 CHECK_NUMBER (count, 1);
855
856 n = XINT (count);
857 if (n <= 0)
858 return Qnil;
859 strlen = min (n, 256);
860 string = (unsigned char *) alloca (strlen);
861 for (i = 0; i < strlen; i++)
862 string[i] = XFASTINT (chr);
863 while (n >= strlen)
864 {
865 insert (string, strlen);
866 n -= strlen;
867 }
868 if (n > 0)
869 insert (string, n);
870 return Qnil;
871 }
872
873 \f
874 /* Making strings from buffer contents. */
875
876 /* Return a Lisp_String containing the text of the current buffer from
877 START to END. If text properties are in use and the current buffer
878 has properties in the range specified, the resulting string will also
879 have them.
880
881 We don't want to use plain old make_string here, because it calls
882 make_uninit_string, which can cause the buffer arena to be
883 compacted. make_string has no way of knowing that the data has
884 been moved, and thus copies the wrong data into the string. This
885 doesn't effect most of the other users of make_string, so it should
886 be left as is. But we should use this function when conjuring
887 buffer substrings. */
888
889 Lisp_Object
890 make_buffer_string (start, end)
891 int start, end;
892 {
893 Lisp_Object result;
894
895 if (start < GPT && GPT < end)
896 move_gap (start);
897
898 result = make_uninit_string (end - start);
899 bcopy (&FETCH_CHAR (start), XSTRING (result)->data, end - start);
900
901 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
902 copy_intervals_to_string (result, current_buffer, start, end - start);
903
904 return result;
905 }
906
907 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 2, 2, 0,
908 "Return the contents of part of the current buffer as a string.\n\
909 The two arguments START and END are character positions;\n\
910 they can be in either order.")
911 (b, e)
912 Lisp_Object b, e;
913 {
914 register int beg, end;
915
916 validate_region (&b, &e);
917 beg = XINT (b);
918 end = XINT (e);
919
920 return make_buffer_string (beg, end);
921 }
922
923 DEFUN ("buffer-string", Fbuffer_string, Sbuffer_string, 0, 0, 0,
924 "Return the contents of the current buffer as a string.")
925 ()
926 {
927 return make_buffer_string (BEGV, ZV);
928 }
929
930 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
931 1, 3, 0,
932 "Insert before point a substring of the contents of buffer BUFFER.\n\
933 BUFFER may be a buffer or a buffer name.\n\
934 Arguments START and END are character numbers specifying the substring.\n\
935 They default to the beginning and the end of BUFFER.")
936 (buf, b, e)
937 Lisp_Object buf, b, e;
938 {
939 register int beg, end, temp, len, opoint, start;
940 register struct buffer *bp;
941 Lisp_Object buffer;
942
943 buffer = Fget_buffer (buf);
944 if (NILP (buffer))
945 nsberror (buf);
946 bp = XBUFFER (buffer);
947
948 if (NILP (b))
949 beg = BUF_BEGV (bp);
950 else
951 {
952 CHECK_NUMBER_COERCE_MARKER (b, 0);
953 beg = XINT (b);
954 }
955 if (NILP (e))
956 end = BUF_ZV (bp);
957 else
958 {
959 CHECK_NUMBER_COERCE_MARKER (e, 1);
960 end = XINT (e);
961 }
962
963 if (beg > end)
964 temp = beg, beg = end, end = temp;
965
966 /* Move the gap or create enough gap in the current buffer. */
967
968 if (point != GPT)
969 move_gap (point);
970 if (GAP_SIZE < end - beg)
971 make_gap (end - beg - GAP_SIZE);
972
973 len = end - beg;
974 start = beg;
975 opoint = point;
976
977 if (!(BUF_BEGV (bp) <= beg
978 && beg <= end
979 && end <= BUF_ZV (bp)))
980 args_out_of_range (b, e);
981
982 /* Now the actual insertion will not do any gap motion,
983 so it matters not if BUF is the current buffer. */
984 if (beg < BUF_GPT (bp))
985 {
986 insert (BUF_CHAR_ADDRESS (bp, beg), min (end, BUF_GPT (bp)) - beg);
987 beg = min (end, BUF_GPT (bp));
988 }
989 if (beg < end)
990 insert (BUF_CHAR_ADDRESS (bp, beg), end - beg);
991
992 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
993 graft_intervals_into_buffer (copy_intervals (bp->intervals, start, len),
994 opoint, bp, 0);
995
996 return Qnil;
997 }
998
999 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
1000 6, 6, 0,
1001 "Compare two substrings of two buffers; return result as number.\n\
1002 the value is -N if first string is less after N-1 chars,\n\
1003 +N if first string is greater after N-1 chars, or 0 if strings match.\n\
1004 Each substring is represented as three arguments: BUFFER, START and END.\n\
1005 That makes six args in all, three for each substring.\n\n\
1006 The value of `case-fold-search' in the current buffer\n\
1007 determines whether case is significant or ignored.")
1008 (buffer1, start1, end1, buffer2, start2, end2)
1009 Lisp_Object buffer1, start1, end1, buffer2, start2, end2;
1010 {
1011 register int begp1, endp1, begp2, endp2, temp, len1, len2, length, i;
1012 register struct buffer *bp1, *bp2;
1013 register unsigned char *trt
1014 = (!NILP (current_buffer->case_fold_search)
1015 ? XSTRING (current_buffer->case_canon_table)->data : 0);
1016
1017 /* Find the first buffer and its substring. */
1018
1019 if (NILP (buffer1))
1020 bp1 = current_buffer;
1021 else
1022 {
1023 Lisp_Object buf1;
1024 buf1 = Fget_buffer (buffer1);
1025 if (NILP (buf1))
1026 nsberror (buffer1);
1027 bp1 = XBUFFER (buf1);
1028 }
1029
1030 if (NILP (start1))
1031 begp1 = BUF_BEGV (bp1);
1032 else
1033 {
1034 CHECK_NUMBER_COERCE_MARKER (start1, 1);
1035 begp1 = XINT (start1);
1036 }
1037 if (NILP (end1))
1038 endp1 = BUF_ZV (bp1);
1039 else
1040 {
1041 CHECK_NUMBER_COERCE_MARKER (end1, 2);
1042 endp1 = XINT (end1);
1043 }
1044
1045 if (begp1 > endp1)
1046 temp = begp1, begp1 = endp1, endp1 = temp;
1047
1048 if (!(BUF_BEGV (bp1) <= begp1
1049 && begp1 <= endp1
1050 && endp1 <= BUF_ZV (bp1)))
1051 args_out_of_range (start1, end1);
1052
1053 /* Likewise for second substring. */
1054
1055 if (NILP (buffer2))
1056 bp2 = current_buffer;
1057 else
1058 {
1059 Lisp_Object buf2;
1060 buf2 = Fget_buffer (buffer2);
1061 if (NILP (buf2))
1062 nsberror (buffer2);
1063 bp2 = XBUFFER (buffer2);
1064 }
1065
1066 if (NILP (start2))
1067 begp2 = BUF_BEGV (bp2);
1068 else
1069 {
1070 CHECK_NUMBER_COERCE_MARKER (start2, 4);
1071 begp2 = XINT (start2);
1072 }
1073 if (NILP (end2))
1074 endp2 = BUF_ZV (bp2);
1075 else
1076 {
1077 CHECK_NUMBER_COERCE_MARKER (end2, 5);
1078 endp2 = XINT (end2);
1079 }
1080
1081 if (begp2 > endp2)
1082 temp = begp2, begp2 = endp2, endp2 = temp;
1083
1084 if (!(BUF_BEGV (bp2) <= begp2
1085 && begp2 <= endp2
1086 && endp2 <= BUF_ZV (bp2)))
1087 args_out_of_range (start2, end2);
1088
1089 len1 = endp1 - begp1;
1090 len2 = endp2 - begp2;
1091 length = len1;
1092 if (len2 < length)
1093 length = len2;
1094
1095 for (i = 0; i < length; i++)
1096 {
1097 int c1 = *BUF_CHAR_ADDRESS (bp1, begp1 + i);
1098 int c2 = *BUF_CHAR_ADDRESS (bp2, begp2 + i);
1099 if (trt)
1100 {
1101 c1 = trt[c1];
1102 c2 = trt[c2];
1103 }
1104 if (c1 < c2)
1105 return make_number (- 1 - i);
1106 if (c1 > c2)
1107 return make_number (i + 1);
1108 }
1109
1110 /* The strings match as far as they go.
1111 If one is shorter, that one is less. */
1112 if (length < len1)
1113 return make_number (length + 1);
1114 else if (length < len2)
1115 return make_number (- length - 1);
1116
1117 /* Same length too => they are equal. */
1118 return make_number (0);
1119 }
1120 \f
1121 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
1122 Ssubst_char_in_region, 4, 5, 0,
1123 "From START to END, replace FROMCHAR with TOCHAR each time it occurs.\n\
1124 If optional arg NOUNDO is non-nil, don't record this change for undo\n\
1125 and don't mark the buffer as really changed.")
1126 (start, end, fromchar, tochar, noundo)
1127 Lisp_Object start, end, fromchar, tochar, noundo;
1128 {
1129 register int pos, stop, look;
1130
1131 validate_region (&start, &end);
1132 CHECK_NUMBER (fromchar, 2);
1133 CHECK_NUMBER (tochar, 3);
1134
1135 pos = XINT (start);
1136 stop = XINT (end);
1137 look = XINT (fromchar);
1138
1139 modify_region (current_buffer, pos, stop);
1140 if (! NILP (noundo))
1141 {
1142 if (MODIFF - 1 == current_buffer->save_modified)
1143 current_buffer->save_modified++;
1144 if (MODIFF - 1 == current_buffer->auto_save_modified)
1145 current_buffer->auto_save_modified++;
1146 }
1147
1148 while (pos < stop)
1149 {
1150 if (FETCH_CHAR (pos) == look)
1151 {
1152 if (NILP (noundo))
1153 record_change (pos, 1);
1154 FETCH_CHAR (pos) = XINT (tochar);
1155 if (NILP (noundo))
1156 signal_after_change (pos, 1, 1);
1157 }
1158 pos++;
1159 }
1160
1161 return Qnil;
1162 }
1163
1164 DEFUN ("translate-region", Ftranslate_region, Stranslate_region, 3, 3, 0,
1165 "From START to END, translate characters according to TABLE.\n\
1166 TABLE is a string; the Nth character in it is the mapping\n\
1167 for the character with code N. Returns the number of characters changed.")
1168 (start, end, table)
1169 Lisp_Object start;
1170 Lisp_Object end;
1171 register Lisp_Object table;
1172 {
1173 register int pos, stop; /* Limits of the region. */
1174 register unsigned char *tt; /* Trans table. */
1175 register int oc; /* Old character. */
1176 register int nc; /* New character. */
1177 int cnt; /* Number of changes made. */
1178 Lisp_Object z; /* Return. */
1179 int size; /* Size of translate table. */
1180
1181 validate_region (&start, &end);
1182 CHECK_STRING (table, 2);
1183
1184 size = XSTRING (table)->size;
1185 tt = XSTRING (table)->data;
1186
1187 pos = XINT (start);
1188 stop = XINT (end);
1189 modify_region (current_buffer, pos, stop);
1190
1191 cnt = 0;
1192 for (; pos < stop; ++pos)
1193 {
1194 oc = FETCH_CHAR (pos);
1195 if (oc < size)
1196 {
1197 nc = tt[oc];
1198 if (nc != oc)
1199 {
1200 record_change (pos, 1);
1201 FETCH_CHAR (pos) = nc;
1202 signal_after_change (pos, 1, 1);
1203 ++cnt;
1204 }
1205 }
1206 }
1207
1208 XFASTINT (z) = cnt;
1209 return (z);
1210 }
1211
1212 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 2, "r",
1213 "Delete the text between point and mark.\n\
1214 When called from a program, expects two arguments,\n\
1215 positions (integers or markers) specifying the stretch to be deleted.")
1216 (b, e)
1217 Lisp_Object b, e;
1218 {
1219 validate_region (&b, &e);
1220 del_range (XINT (b), XINT (e));
1221 return Qnil;
1222 }
1223 \f
1224 DEFUN ("widen", Fwiden, Swiden, 0, 0, "",
1225 "Remove restrictions (narrowing) from current buffer.\n\
1226 This allows the buffer's full text to be seen and edited.")
1227 ()
1228 {
1229 BEGV = BEG;
1230 SET_BUF_ZV (current_buffer, Z);
1231 clip_changed = 1;
1232 /* Changing the buffer bounds invalidates any recorded current column. */
1233 invalidate_current_column ();
1234 return Qnil;
1235 }
1236
1237 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r",
1238 "Restrict editing in this buffer to the current region.\n\
1239 The rest of the text becomes temporarily invisible and untouchable\n\
1240 but is not deleted; if you save the buffer in a file, the invisible\n\
1241 text is included in the file. \\[widen] makes all visible again.\n\
1242 See also `save-restriction'.\n\
1243 \n\
1244 When calling from a program, pass two arguments; positions (integers\n\
1245 or markers) bounding the text that should remain visible.")
1246 (b, e)
1247 register Lisp_Object b, e;
1248 {
1249 register int i;
1250
1251 CHECK_NUMBER_COERCE_MARKER (b, 0);
1252 CHECK_NUMBER_COERCE_MARKER (e, 1);
1253
1254 if (XINT (b) > XINT (e))
1255 {
1256 i = XFASTINT (b);
1257 b = e;
1258 XFASTINT (e) = i;
1259 }
1260
1261 if (!(BEG <= XINT (b) && XINT (b) <= XINT (e) && XINT (e) <= Z))
1262 args_out_of_range (b, e);
1263
1264 BEGV = XFASTINT (b);
1265 SET_BUF_ZV (current_buffer, XFASTINT (e));
1266 if (point < XFASTINT (b))
1267 SET_PT (XFASTINT (b));
1268 if (point > XFASTINT (e))
1269 SET_PT (XFASTINT (e));
1270 clip_changed = 1;
1271 /* Changing the buffer bounds invalidates any recorded current column. */
1272 invalidate_current_column ();
1273 return Qnil;
1274 }
1275
1276 Lisp_Object
1277 save_restriction_save ()
1278 {
1279 register Lisp_Object bottom, top;
1280 /* Note: I tried using markers here, but it does not win
1281 because insertion at the end of the saved region
1282 does not advance mh and is considered "outside" the saved region. */
1283 XFASTINT (bottom) = BEGV - BEG;
1284 XFASTINT (top) = Z - ZV;
1285
1286 return Fcons (Fcurrent_buffer (), Fcons (bottom, top));
1287 }
1288
1289 Lisp_Object
1290 save_restriction_restore (data)
1291 Lisp_Object data;
1292 {
1293 register struct buffer *buf;
1294 register int newhead, newtail;
1295 register Lisp_Object tem;
1296
1297 buf = XBUFFER (XCONS (data)->car);
1298
1299 data = XCONS (data)->cdr;
1300
1301 tem = XCONS (data)->car;
1302 newhead = XINT (tem);
1303 tem = XCONS (data)->cdr;
1304 newtail = XINT (tem);
1305 if (newhead + newtail > BUF_Z (buf) - BUF_BEG (buf))
1306 {
1307 newhead = 0;
1308 newtail = 0;
1309 }
1310 BUF_BEGV (buf) = BUF_BEG (buf) + newhead;
1311 SET_BUF_ZV (buf, BUF_Z (buf) - newtail);
1312 clip_changed = 1;
1313
1314 /* If point is outside the new visible range, move it inside. */
1315 SET_BUF_PT (buf,
1316 clip_to_bounds (BUF_BEGV (buf), BUF_PT (buf), BUF_ZV (buf)));
1317
1318 return Qnil;
1319 }
1320
1321 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0,
1322 "Execute BODY, saving and restoring current buffer's restrictions.\n\
1323 The buffer's restrictions make parts of the beginning and end invisible.\n\
1324 \(They are set up with `narrow-to-region' and eliminated with `widen'.)\n\
1325 This special form, `save-restriction', saves the current buffer's restrictions\n\
1326 when it is entered, and restores them when it is exited.\n\
1327 So any `narrow-to-region' within BODY lasts only until the end of the form.\n\
1328 The old restrictions settings are restored\n\
1329 even in case of abnormal exit (throw or error).\n\
1330 \n\
1331 The value returned is the value of the last form in BODY.\n\
1332 \n\
1333 `save-restriction' can get confused if, within the BODY, you widen\n\
1334 and then make changes outside the area within the saved restrictions.\n\
1335 \n\
1336 Note: if you are using both `save-excursion' and `save-restriction',\n\
1337 use `save-excursion' outermost:\n\
1338 (save-excursion (save-restriction ...))")
1339 (body)
1340 Lisp_Object body;
1341 {
1342 register Lisp_Object val;
1343 int count = specpdl_ptr - specpdl;
1344
1345 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1346 val = Fprogn (body);
1347 return unbind_to (count, val);
1348 }
1349 \f
1350 DEFUN ("message", Fmessage, Smessage, 1, MANY, 0,
1351 "Print a one-line message at the bottom of the screen.\n\
1352 The first argument is a control string.\n\
1353 It may contain %s or %d or %c to print successive following arguments.\n\
1354 %s means print an argument as a string, %d means print as number in decimal,\n\
1355 %c means print a number as a single character.\n\
1356 The argument used by %s must be a string or a symbol;\n\
1357 the argument used by %d or %c must be a number.\n\
1358 If the first argument is nil, clear any existing message; let the\n\
1359 minibuffer contents show.")
1360 (nargs, args)
1361 int nargs;
1362 Lisp_Object *args;
1363 {
1364 if (NILP (args[0]))
1365 {
1366 message (0);
1367 return Qnil;
1368 }
1369 else
1370 {
1371 register Lisp_Object val;
1372 val = Fformat (nargs, args);
1373 message ("%s", XSTRING (val)->data);
1374 return val;
1375 }
1376 }
1377
1378 DEFUN ("format", Fformat, Sformat, 1, MANY, 0,
1379 "Format a string out of a control-string and arguments.\n\
1380 The first argument is a control string.\n\
1381 The other arguments are substituted into it to make the result, a string.\n\
1382 It may contain %-sequences meaning to substitute the next argument.\n\
1383 %s means print a string argument. Actually, prints any object, with `princ'.\n\
1384 %d means print as number in decimal (%o octal, %x hex).\n\
1385 %c means print a number as a single character.\n\
1386 %S means print any object as an s-expression (using prin1).\n\
1387 The argument used for %d, %o, %x or %c must be a number.\n\
1388 Use %% to put a single % into the output.")
1389 (nargs, args)
1390 int nargs;
1391 register Lisp_Object *args;
1392 {
1393 register int n; /* The number of the next arg to substitute */
1394 register int total = 5; /* An estimate of the final length */
1395 char *buf;
1396 register unsigned char *format, *end;
1397 int length;
1398 extern char *index ();
1399 /* It should not be necessary to GCPRO ARGS, because
1400 the caller in the interpreter should take care of that. */
1401
1402 CHECK_STRING (args[0], 0);
1403 format = XSTRING (args[0])->data;
1404 end = format + XSTRING (args[0])->size;
1405
1406 n = 0;
1407 while (format != end)
1408 if (*format++ == '%')
1409 {
1410 int minlen;
1411
1412 /* Process a numeric arg and skip it. */
1413 minlen = atoi (format);
1414 if (minlen > 0)
1415 total += minlen;
1416 else
1417 total -= minlen;
1418 while ((*format >= '0' && *format <= '9')
1419 || *format == '-' || *format == ' ' || *format == '.')
1420 format++;
1421
1422 if (*format == '%')
1423 format++;
1424 else if (++n >= nargs)
1425 ;
1426 else if (*format == 'S')
1427 {
1428 /* For `S', prin1 the argument and then treat like a string. */
1429 register Lisp_Object tem;
1430 tem = Fprin1_to_string (args[n], Qnil);
1431 args[n] = tem;
1432 goto string;
1433 }
1434 else if (XTYPE (args[n]) == Lisp_Symbol)
1435 {
1436 XSET (args[n], Lisp_String, XSYMBOL (args[n])->name);
1437 goto string;
1438 }
1439 else if (XTYPE (args[n]) == Lisp_String)
1440 {
1441 string:
1442 total += XSTRING (args[n])->size;
1443 }
1444 /* Would get MPV otherwise, since Lisp_Int's `point' to low memory. */
1445 else if (XTYPE (args[n]) == Lisp_Int && *format != 's')
1446 {
1447 #ifdef LISP_FLOAT_TYPE
1448 /* The following loop assumes the Lisp type indicates
1449 the proper way to pass the argument.
1450 So make sure we have a flonum if the argument should
1451 be a double. */
1452 if (*format == 'e' || *format == 'f' || *format == 'g')
1453 args[n] = Ffloat (args[n]);
1454 #endif
1455 total += 10;
1456 }
1457 #ifdef LISP_FLOAT_TYPE
1458 else if (XTYPE (args[n]) == Lisp_Float && *format != 's')
1459 {
1460 if (! (*format == 'e' || *format == 'f' || *format == 'g'))
1461 args[n] = Ftruncate (args[n]);
1462 total += 20;
1463 }
1464 #endif
1465 else
1466 {
1467 /* Anything but a string, convert to a string using princ. */
1468 register Lisp_Object tem;
1469 tem = Fprin1_to_string (args[n], Qt);
1470 args[n] = tem;
1471 goto string;
1472 }
1473 }
1474
1475 {
1476 register int nstrings = n + 1;
1477
1478 /* Allocate twice as many strings as we have %-escapes; floats occupy
1479 two slots, and we're not sure how many of those we have. */
1480 register unsigned char **strings
1481 = (unsigned char **) alloca (2 * nstrings * sizeof (unsigned char *));
1482 int i;
1483
1484 i = 0;
1485 for (n = 0; n < nstrings; n++)
1486 {
1487 if (n >= nargs)
1488 strings[i++] = (unsigned char *) "";
1489 else if (XTYPE (args[n]) == Lisp_Int)
1490 /* We checked above that the corresponding format effector
1491 isn't %s, which would cause MPV. */
1492 strings[i++] = (unsigned char *) XINT (args[n]);
1493 #ifdef LISP_FLOAT_TYPE
1494 else if (XTYPE (args[n]) == Lisp_Float)
1495 {
1496 union { double d; int half[2]; } u;
1497
1498 u.d = XFLOAT (args[n])->data;
1499 strings[i++] = (unsigned char *) u.half[0];
1500 strings[i++] = (unsigned char *) u.half[1];
1501 }
1502 #endif
1503 else
1504 strings[i++] = XSTRING (args[n])->data;
1505 }
1506
1507 /* Format it in bigger and bigger buf's until it all fits. */
1508 while (1)
1509 {
1510 buf = (char *) alloca (total + 1);
1511 buf[total - 1] = 0;
1512
1513 length = doprnt (buf, total + 1, strings[0], end, i-1, strings + 1);
1514 if (buf[total - 1] == 0)
1515 break;
1516
1517 total *= 2;
1518 }
1519 }
1520
1521 /* UNGCPRO; */
1522 return make_string (buf, length);
1523 }
1524
1525 /* VARARGS 1 */
1526 Lisp_Object
1527 #ifdef NO_ARG_ARRAY
1528 format1 (string1, arg0, arg1, arg2, arg3, arg4)
1529 int arg0, arg1, arg2, arg3, arg4;
1530 #else
1531 format1 (string1)
1532 #endif
1533 char *string1;
1534 {
1535 char buf[100];
1536 #ifdef NO_ARG_ARRAY
1537 int args[5];
1538 args[0] = arg0;
1539 args[1] = arg1;
1540 args[2] = arg2;
1541 args[3] = arg3;
1542 args[4] = arg4;
1543 doprnt (buf, sizeof buf, string1, 0, 5, args);
1544 #else
1545 doprnt (buf, sizeof buf, string1, 0, 5, &string1 + 1);
1546 #endif
1547 return build_string (buf);
1548 }
1549 \f
1550 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 2, 0,
1551 "Return t if two characters match, optionally ignoring case.\n\
1552 Both arguments must be characters (i.e. integers).\n\
1553 Case is ignored if `case-fold-search' is non-nil in the current buffer.")
1554 (c1, c2)
1555 register Lisp_Object c1, c2;
1556 {
1557 unsigned char *downcase = DOWNCASE_TABLE;
1558 CHECK_NUMBER (c1, 0);
1559 CHECK_NUMBER (c2, 1);
1560
1561 if (!NILP (current_buffer->case_fold_search)
1562 ? (downcase[0xff & XFASTINT (c1)] == downcase[0xff & XFASTINT (c2)]
1563 && (XFASTINT (c1) & ~0xff) == (XFASTINT (c2) & ~0xff))
1564 : XINT (c1) == XINT (c2))
1565 return Qt;
1566 return Qnil;
1567 }
1568
1569 \f
1570 void
1571 syms_of_editfns ()
1572 {
1573 staticpro (&Vuser_name);
1574 staticpro (&Vuser_full_name);
1575 staticpro (&Vuser_real_name);
1576 staticpro (&Vsystem_name);
1577
1578 defsubr (&Schar_equal);
1579 defsubr (&Sgoto_char);
1580 defsubr (&Sstring_to_char);
1581 defsubr (&Schar_to_string);
1582 defsubr (&Sbuffer_substring);
1583 defsubr (&Sbuffer_string);
1584
1585 defsubr (&Spoint_marker);
1586 defsubr (&Smark_marker);
1587 defsubr (&Spoint);
1588 defsubr (&Sregion_beginning);
1589 defsubr (&Sregion_end);
1590 /* defsubr (&Smark); */
1591 /* defsubr (&Sset_mark); */
1592 defsubr (&Ssave_excursion);
1593
1594 defsubr (&Sbufsize);
1595 defsubr (&Spoint_max);
1596 defsubr (&Spoint_min);
1597 defsubr (&Spoint_min_marker);
1598 defsubr (&Spoint_max_marker);
1599
1600 defsubr (&Sbobp);
1601 defsubr (&Seobp);
1602 defsubr (&Sbolp);
1603 defsubr (&Seolp);
1604 defsubr (&Sfollowing_char);
1605 defsubr (&Sprevious_char);
1606 defsubr (&Schar_after);
1607 defsubr (&Sinsert);
1608 defsubr (&Sinsert_before_markers);
1609 defsubr (&Sinsert_and_inherit);
1610 defsubr (&Sinsert_and_inherit_before_markers);
1611 defsubr (&Sinsert_char);
1612
1613 defsubr (&Suser_login_name);
1614 defsubr (&Suser_real_login_name);
1615 defsubr (&Suser_uid);
1616 defsubr (&Suser_real_uid);
1617 defsubr (&Suser_full_name);
1618 defsubr (&Scurrent_time);
1619 defsubr (&Scurrent_time_string);
1620 defsubr (&Scurrent_time_zone);
1621 defsubr (&Ssystem_name);
1622 defsubr (&Smessage);
1623 defsubr (&Sformat);
1624
1625 defsubr (&Sinsert_buffer_substring);
1626 defsubr (&Scompare_buffer_substrings);
1627 defsubr (&Ssubst_char_in_region);
1628 defsubr (&Stranslate_region);
1629 defsubr (&Sdelete_region);
1630 defsubr (&Swiden);
1631 defsubr (&Snarrow_to_region);
1632 defsubr (&Ssave_restriction);
1633 }