Mercurial > hg > xemacs-beta

comparison src/editfns.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 9ee227acff29
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Lisp functions pertaining to editing.
2 Copyright (C) 1985-1987, 1989, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
4 Copyright (C) 1996 Ben Wing.
5
6 This file is part of XEmacs.
7
8 XEmacs is free software; you can redistribute it and/or modify it
9 under the terms of the GNU General Public License as published by the
10 Free Software Foundation; either version 2, or (at your option) any
11 later version.
12
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with XEmacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 Boston, MA 02111-1307, USA. */
22
23 /* Synched up with: Mule 2.0, FSF 19.30. */
24
25 /* This file has been Mule-ized. */
26
27 /* Hacked on for Mule by Ben Wing, December 1994. */
28
29 #include <config.h>
30 #include "lisp.h"
31
32 #include "buffer.h"
33 #include "commands.h"
34 #include "events.h" /* for EVENTP */
35 #include "extents.h"
36 #include "frame.h"
37 #include "insdel.h"
38 #include "window.h"
39
40 #include "systime.h"
41 #include "sysdep.h"
42 #include "syspwd.h"
43
44 /* Some static data, and a function to initialize it for each run */
45
46 Lisp_Object Vsystem_name; /* #### - I don't see why this should be */
47 /* static, either... --Stig */
48 #if 0 /* XEmacs - this is now dynamic */
49 /* if at some point it's deemed desirable to
50 use lisp variables here, then they can be
51 initialized to nil and then set to their
52 real values upon the first call to the
53 functions that generate them. --stig */
54 Lisp_Object Vuser_real_login_name; /* login name of current user ID */
55 Lisp_Object Vuser_full_name; /* full name of current user */
56 Lisp_Object Vuser_login_name; /* user name from LOGNAME or USER. */
57 #endif
58
59 extern char *get_system_name (void);
60
61 Lisp_Object Qformat;
62
63 Lisp_Object Qpoint, Qmark, Qregion_beginning, Qregion_end;
64
65 /* This holds the value of `environ' produced by the previous
66 call to Fset_time_zone_rule, or 0 if Fset_time_zone_rule
67 has never been called. */
68 static char **environbuf;
69
70 void
71 init_editfns (void)
72 {
73 /* Only used in removed code below. */
74 #if 0
75 char *user_name;
76 Bufbyte *p, *q;
77 struct passwd *pw; /* password entry for the current user */
78 Lisp_Object tem;
79 #endif
80
81 environbuf = 0;
82
83 /* Set up system_name even when dumping. */
84 init_system_name ();
85
86 #if 0 /* this is now dynamic */
87 /* don't lose utterly if someone uses these during loadup. */
88 Vuser_real_login_name = Qnil;
89 Vuser_login_name = Qnil;
90 Vuser_full_name = Qnil;
91
92 #ifndef CANNOT_DUMP
93 /* Don't bother with this on initial start when just dumping out */
94 if (!initialized)
95 return;
96 #endif /* not CANNOT_DUMP */
97
98 pw = (struct passwd *) getpwuid (getuid ());
99 #ifdef MSDOS
100 /* We let the real user name default to "root" because that's quite
101 accurate on MSDOG and because it lets Emacs find the init file.
102 (The DVX libraries override the Djgpp libraries here.) */
103 Vuser_real_login_name = build_string (pw ? pw->pw_name : "root");
104 #else
105 Vuser_real_login_name = build_string (pw ? pw->pw_name : "unknown");
106 #endif
107
108 /* Get the effective user name, by consulting environment variables,
109 or the effective uid if those are unset. */
110 user_name = getenv ("LOGNAME");
111 if (!user_name)
112 #ifdef WINDOWSNT
113 user_name = (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
114 #else /* WINDOWSNT */
115 user_name = (char *) getenv ("USER");
116 #endif /* WINDOWSNT */
117 if (!user_name)
118 {
119 /* #### - do we really want the EFFECTIVE uid here? Are these flipped? */
120 /* I ask because LOGNAME and USER vars WILL NOT MATCH the euid. --Stig */
121 pw = (struct passwd *) getpwuid (geteuid ());
122 user_name = (char *) (pw ? pw->pw_name : "unknown");
123 }
124 Vuser_login_name = build_string (user_name);
125
126 /* If the user name claimed in the environment vars differs from
127 the real uid, use the claimed name to find the full name. */
128 tem = Fstring_equal (Vuser_login_name, Vuser_real_login_name);
129 if (NILP (tem))
130 {
131 /* Jamie reports that IRIX gets wedged by SIGIO/SIGALARM occurring
132 in select(), called from getpwnam(). */
133 slow_down_interrupts ();
134 pw = (struct passwd *)
135 getpwnam ((char *) string_data (XSTRING (Vuser_login_name)));
136 speed_up_interrupts ();
137 }
138
139 p = (Bufbyte *) ((pw) ? USER_FULL_NAME : "unknown"); /* don't gettext here */
140 q = (Bufbyte *) strchr ((char *) p, ',');
141 Vuser_full_name = make_ext_string (p, (q ? q - p : strlen ((char *) p)),
142 FORMAT_OS);
143
144 #ifdef AMPERSAND_FULL_NAME
145 p = string_data (XSTRING (Vuser_full_name));
146 q = (Bufbyte *) strchr ((char *) p, '&');
147 /* Substitute the login name for the &, upcasing the first character. */
148 if (q)
149 {
150 char *r = (char *)
151 alloca (strlen ((char *) p) +
152 string_length (XSTRING (Vuser_login_name)) + 1);
153 Charcount fullname_off = bytecount_to_charcount (p, q - p);
154 memcpy (r, p, q - p);
155 r[q - p] = 0;
156 strcat (r, (char *) string_data (XSTRING (Vuser_login_name)));
157 strcat (r, q + 1);
158 Vuser_full_name = build_string (r);
159 set_string_char (XSTRING (Vuser_full_name), fullname_off,
160 UPCASE (current_buffer,
161 string_char (XSTRING (Vuser_full_name),
162 fullname_off)));
163 }
164 #endif /* AMPERSAND_FULL_NAME */
165
166 p = (Bufbyte *) getenv ("NAME");
167 if (p)
168 Vuser_full_name = build_string ((char *) p);
169 #endif /* 0 */
170 }
171
172 DEFUN ("char-to-string", Fchar_to_string, Schar_to_string, 1, 1, 0 /*
173 Convert arg CH to a one-character string containing that character.
174 */ )
175 (ch)
176 Lisp_Object ch;
177 {
178 Bytecount len;
179 Bufbyte str[MAX_EMCHAR_LEN];
180
181 if (EVENTP (ch))
182 {
183 Lisp_Object ch2 = Fevent_to_character (ch, Qt, Qnil, Qnil);
184 if (NILP (ch2))
185 return
186 signal_simple_continuable_error
187 ("character has no ASCII equivalent:", Fcopy_event (ch, Qnil));
188 ch = ch2;
189 }
190
191 CHECK_CHAR_COERCE_INT (ch);
192
193 len = set_charptr_emchar (str, XCHAR (ch));
194 return make_string (str, len);
195 }
196
197 DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0 /*
198 Convert arg STRING to a character, the first character of that string.
199 */ )
200 (str)
201 Lisp_Object str;
202 {
203 struct Lisp_String *p;
204 CHECK_STRING (str);
205
206 p = XSTRING (str);
207 if (string_length (p) != 0)
208 {
209 return (make_char (string_char (p, 0)));
210 }
211 else /* #### Gag me! */
212 return (Qzero);
213 }
214
215
216 static Lisp_Object
217 buildmark (Bufpos val, Lisp_Object buffer)
218 {
219 Lisp_Object mark;
220 mark = Fmake_marker ();
221 Fset_marker (mark, make_int (val), buffer);
222 return mark;
223 }
224
225 DEFUN ("point", Fpoint, Spoint, 0, 1, 0 /*
226 Return value of point, as an integer.
227 Beginning of buffer is position (point-min).
228 If BUFFER is nil, the current buffer is assumed.
229 */ )
230 (buffer)
231 Lisp_Object buffer;
232 {
233 struct buffer *b = decode_buffer (buffer, 1);
234 return (make_int (BUF_PT (b)));
235 }
236
237 DEFUN ("point-marker", Fpoint_marker, Spoint_marker, 0, 2, 0 /*
238 Return value of point, as a marker object.
239 This marker is a copy; you may modify it with reckless abandon.
240 If optional argument DONT-COPY-P is non-nil, then it returns the real
241 point-marker; modifying the position of this marker will move point.
242 It is illegal to change the buffer of it, or make it point nowhere.
243 If BUFFER is nil, the current buffer is assumed.
244 */ )
245 (dont_copy_p, buffer)
246 Lisp_Object dont_copy_p, buffer;
247 {
248 struct buffer *b = decode_buffer (buffer, 1);
249 if (NILP (dont_copy_p))
250 return Fcopy_marker (b->point_marker, Qnil);
251 return b->point_marker;
252 }
253
254 /* The following two functions end up being identical but it's
255 cleaner to declare them separately. */
256
257 Bufpos
258 bufpos_clip_to_bounds (Bufpos lower, Bufpos num, Bufpos upper)
259 {
260 if (num < lower)
261 return lower;
262 else if (num > upper)
263 return upper;
264 else
265 return num;
266 }
267
268 Bytind
269 bytind_clip_to_bounds (Bytind lower, Bytind num, Bytind upper)
270 {
271 if (num < lower)
272 return lower;
273 else if (num > upper)
274 return upper;
275 else
276 return num;
277 }
278
279 /*
280 * Chuck says:
281 * There is no absolute way to determine if goto-char is the function
282 * being run. this-command doesn't work because it is often eval'd
283 * and this-command ends up set to eval-expression. So this flag gets
284 * added for now.
285 *
286 * Jamie thinks he's wrong, but we'll leave this in for now.
287 */
288 int atomic_extent_goto_char_p;
289
290 DEFUN ("goto-char", Fgoto_char, Sgoto_char, 1, 2, "NGoto char: " /*
291 Set point to POSITION, a number or marker.
292 Beginning of buffer is position (point-min), end is (point-max).
293 If BUFFER is nil, the current buffer is assumed.
294 Return value of POSITION, as an integer.
295 */ )
296 (position, buffer)
297 Lisp_Object position, buffer;
298 {
299 struct buffer *b = decode_buffer (buffer, 1);
300 Bufpos n = get_buffer_pos_char (b, position, GB_COERCE_RANGE);
301 BUF_SET_PT (b, n);
302 atomic_extent_goto_char_p = 1;
303 return (make_int (n));
304 }
305
306 static Lisp_Object
307 region_limit (int beginningp, struct buffer *b)
308 {
309 Lisp_Object m;
310
311 #if 0 /* FSFmacs */
312 if (!NILP (Vtransient_mark_mode) && NILP (Vmark_even_if_inactive)
313 && NILP (b->mark_active))
314 Fsignal (Qmark_inactive, Qnil);
315 #endif
316 m = Fmarker_position (b->mark);
317 if (NILP (m)) error ("There is no region now");
318 if (!!(BUF_PT (b) < XINT (m)) == !!beginningp)
319 return (make_int (BUF_PT (b)));
320 else
321 return (m);
322 }
323
324 DEFUN ("region-beginning", Fregion_beginning, Sregion_beginning, 0, 1, 0 /*
325 Return position of beginning of region, as an integer.
326 If BUFFER is nil, the current buffer is assumed.
327 */ )
328 (buffer)
329 Lisp_Object buffer;
330 {
331 return (region_limit (1, decode_buffer (buffer, 1)));
332 }
333
334 DEFUN ("region-end", Fregion_end, Sregion_end, 0, 1, 0 /*
335 Return position of end of region, as an integer.
336 If BUFFER is nil, the current buffer is assumed.
337 */ )
338 (buffer)
339 Lisp_Object buffer;
340 {
341 return (region_limit (0, decode_buffer (buffer, 1)));
342 }
343
344 /* Whether to use lispm-style active-regions */
345 int zmacs_regions;
346
347 /* Whether the zmacs region is active. This is not per-buffer because
348 there can be only one active region at a time. #### Now that the
349 zmacs region are not directly tied to the X selections this may not
350 necessarily have to be true. */
351 int zmacs_region_active_p;
352
353 int zmacs_region_stays;
354
355 Lisp_Object Qzmacs_update_region, Qzmacs_deactivate_region;
356 Lisp_Object Qzmacs_region_buffer;
357
358 void
359 zmacs_update_region (void)
360 {
361 /* This function can GC */
362 if (zmacs_region_active_p)
363 call0 (Qzmacs_update_region);
364 }
365
366 void
367 zmacs_deactivate_region (void)
368 {
369 /* This function can GC */
370 if (zmacs_region_active_p)
371 call0 (Qzmacs_deactivate_region);
372 }
373
374 Lisp_Object
375 zmacs_region_buffer (void)
376 {
377 if (zmacs_region_active_p)
378 return call0 (Qzmacs_region_buffer);
379 else
380 return Qnil;
381 }
382
383 DEFUN ("mark-marker", Fmark_marker, Smark_marker, 0, 2, 0 /*
384 Return this buffer's mark, as a marker object.
385 If `zmacs-regions' is true, then this returns nil unless the region is
386 currently in the active (highlighted) state. If optional argument FORCE
387 is t, this returns the mark (if there is one) regardless of the zmacs-region
388 state. You should *generally* not use the mark unless the region is active,
389 if the user has expressed a preference for the zmacs-region model.
390 Watch out! Moving this marker changes the mark position.
391 If you set the marker not to point anywhere, the buffer will have no mark.
392 If BUFFER is nil, the current buffer is assumed.
393 */ )
394 (force, buffer)
395 Lisp_Object force, buffer;
396 {
397 struct buffer *b = decode_buffer (buffer, 1);
398 if (! zmacs_regions || zmacs_region_active_p || !NILP (force))
399 return b->mark;
400 return Qnil;
401 }
402
403
404 /* The saved object looks like this:
405
406 (COPY-OF-POINT-MARKER . (COPY-OF-MARK . VISIBLE-P))
407
408 where
409
410 VISIBLE-P is t if `(eq (current-buffer) (window-buffer (selected-window)))'
411 but is not actually used any more.
412 */
413 Lisp_Object
414 save_excursion_save (void)
415 {
416 struct buffer *b;
417 int visible;
418 Lisp_Object tem;
419
420 if (preparing_for_armageddon)
421 return Qnil;
422 else
423 {
424 b = current_buffer;
425 visible = (XBUFFER (XWINDOW (Fselected_window (Qnil))->buffer) == b);
426 tem = ((visible) ? Qt : Qnil);
427 }
428
429 #ifdef ERROR_CHECK_BUFPOS
430 assert (XINT (Fpoint (Qnil)) ==
431 XINT (Fmarker_position (Fpoint_marker (Qt, Qnil))));
432 #endif
433
434 #if 0 /* FSFmacs */
435 tem = Fcons (tem, b->mark_active);
436 #endif
437
438 return noseeum_cons (noseeum_copy_marker (Fpoint_marker (Qt, Qnil), Qnil),
439 noseeum_cons (noseeum_copy_marker (b->mark, Qnil),
440 tem));
441 }
442
443 Lisp_Object
444 save_excursion_restore (Lisp_Object info)
445 {
446 Lisp_Object tem;
447 int visible;
448 struct gcpro gcpro1, gcpro2;
449
450 tem = Fmarker_buffer (Fcar (info));
451 /* If buffer being returned to is now deleted, avoid error */
452 /* Otherwise could get error here while unwinding to top level
453 and crash */
454 /* In that case, Fmarker_buffer returns nil now. */
455 if (NILP (tem))
456 return Qnil;
457 /* Need gcpro in case Lisp hooks get run */
458 GCPRO2 (info, tem);
459 Fset_buffer (tem);
460 tem = Fcar (info);
461 Fgoto_char (tem, Fcurrent_buffer ());
462 tem = Fcar (Fcdr (info));
463 Fset_marker (current_buffer->mark, tem, Fcurrent_buffer ());
464 tem = Fcdr (Fcdr (info));
465 visible = !NILP (tem);
466
467 #if 0 /* We used to make the current buffer visible in the selected window
468 if that was true previously. That avoids some anomalies.
469 But it creates others, and it wasn't documented, and it is simpler
470 and cleaner never to alter the window/buffer connections. */
471 /* #### I'm certain some code somewhere depends on this behavior. --jwz */
472
473 if (visible
474 && (current_buffer != XBUFFER (XWINDOW (selected_window)->buffer)))
475 switch_to_buffer (Fcurrent_buffer (), Qnil);
476 #endif
477
478 UNGCPRO;
479 /* Free all the junk we allocated, so that a `save-excursion' comes
480 for free in terms of GC junk. */
481 free_marker (XMARKER (XCAR (info)));
482 free_marker (XMARKER (XCAR (XCDR (info))));
483 free_cons (XCONS (XCDR (info)));
484 free_cons (XCONS (info));
485 return Qnil;
486 }
487
488 DEFUN ("save-excursion", Fsave_excursion, Ssave_excursion, 0, UNEVALLED, 0 /*
489 Save point, mark, and current buffer; execute BODY; restore those things.
490 Executes BODY just like `progn'.
491 The values of point, mark and the current buffer are restored
492 even in case of abnormal exit (throw or error).
493 */ )
494 (args)
495 Lisp_Object args;
496 {
497 /* This function can GC */
498 int speccount = specpdl_depth ();
499
500 record_unwind_protect (save_excursion_restore, save_excursion_save ());
501
502 return unbind_to (speccount, Fprogn (args));
503 }
504
505 DEFUN ("buffer-size", Fbufsize, Sbufsize, 0, 1, 0 /*
506 Return the number of characters in BUFFER.
507 If BUFFER is nil, the current buffer is assumed.
508 */ )
509 (buffer)
510 Lisp_Object buffer;
511 {
512 struct buffer *b = decode_buffer (buffer, 1);
513 return (make_int (BUF_SIZE (b)));
514 }
515
516 DEFUN ("point-min", Fpoint_min, Spoint_min, 0, 1, 0 /*
517 Return the minimum permissible value of point in BUFFER.
518 This is 1, unless narrowing (a buffer restriction) is in effect.
519 If BUFFER is nil, the current buffer is assumed.
520 */ )
521 (buffer)
522 Lisp_Object buffer;
523 {
524 struct buffer *b = decode_buffer (buffer, 1);
525 return (make_int (BUF_BEGV (b)));
526 }
527
528 DEFUN ("point-min-marker", Fpoint_min_marker, Spoint_min_marker, 0, 1, 0 /*
529 Return a marker to the minimum permissible value of point in BUFFER.
530 This is the beginning, unless narrowing (a buffer restriction) is in effect.
531 If BUFFER is nil, the current buffer is assumed.
532 */ )
533 (buffer)
534 Lisp_Object buffer;
535 {
536 struct buffer *b = decode_buffer (buffer, 1);
537 return buildmark (BUF_BEGV (b), make_buffer (b));
538 }
539
540 DEFUN ("point-max", Fpoint_max, Spoint_max, 0, 1, 0 /*
541 Return the maximum permissible value of point in BUFFER.
542 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
543 is in effect, in which case it is less.
544 If BUFFER is nil, the current buffer is assumed.
545 */ )
546 (buffer)
547 Lisp_Object buffer;
548 {
549 struct buffer *b = decode_buffer (buffer, 1);
550 return (make_int (BUF_ZV (b)));
551 }
552
553 DEFUN ("point-max-marker", Fpoint_max_marker, Spoint_max_marker, 0, 1, 0 /*
554 Return a marker to the maximum permissible value of point BUFFER.
555 This is (1+ (buffer-size)), unless narrowing (a buffer restriction)
556 is in effect, in which case it is less.
557 If BUFFER is nil, the current buffer is assumed.
558 */ )
559 (buffer)
560 Lisp_Object buffer;
561 {
562 struct buffer *b = decode_buffer (buffer, 1);
563 return buildmark (BUF_ZV (b), make_buffer (b));
564 }
565
566 DEFUN ("following-char", Ffollowing_char, Sfollowing_char, 0, 1, 0 /*
567 Return the character following point, as a number.
568 At the end of the buffer or accessible region, return 0.
569 If BUFFER is nil, the current buffer is assumed.
570 */ )
571 (buffer)
572 Lisp_Object buffer;
573 {
574 struct buffer *b = decode_buffer (buffer, 1);
575 if (BUF_PT (b) >= BUF_ZV (b))
576 return (Qzero); /* #### Gag me! */
577 else
578 return (make_char (BUF_FETCH_CHAR (b, BUF_PT (b))));
579 }
580
581 DEFUN ("preceding-char", Fpreceding_char, Spreceding_char, 0, 1, 0 /*
582 Return the character preceding point, as a number.
583 At the beginning of the buffer or accessible region, return 0.
584 If BUFFER is nil, the current buffer is assumed.
585 */ )
586 (buffer)
587 Lisp_Object buffer;
588 {
589 struct buffer *b = decode_buffer (buffer, 1);
590 if (BUF_PT (b) <= BUF_BEGV (b))
591 return (Qzero); /* #### Gag me! */
592 else
593 return (make_char (BUF_FETCH_CHAR (b, BUF_PT (b) - 1)));
594 }
595
596 DEFUN ("bobp", Fbobp, Sbobp, 0, 1, 0 /*
597 Return T if point is at the beginning of the buffer.
598 If the buffer is narrowed, this means the beginning of the narrowed part.
599 If BUFFER is nil, the current buffer is assumed.
600 */ )
601 (buffer)
602 Lisp_Object buffer;
603 {
604 struct buffer *b = decode_buffer (buffer, 1);
605 if (BUF_PT (b) == BUF_BEGV (b))
606 return Qt;
607 return Qnil;
608 }
609
610 DEFUN ("eobp", Feobp, Seobp, 0, 1, 0 /*
611 Return T if point is at the end of the buffer.
612 If the buffer is narrowed, this means the end of the narrowed part.
613 If BUFFER is nil, the current buffer is assumed.
614 */ )
615 (buffer)
616 Lisp_Object buffer;
617 {
618 struct buffer *b = decode_buffer (buffer, 1);
619 if (BUF_PT (b) == BUF_ZV (b))
620 return Qt;
621 return Qnil;
622 }
623
624 int
625 beginning_of_line_p (struct buffer *b, Bufpos pt)
626 {
627 if (pt <= BUF_BEGV (b))
628 return 1;
629 return BUF_FETCH_CHAR (b, pt - 1) == '\n';
630 }
631
632
633 DEFUN ("bolp", Fbolp, Sbolp, 0, 1, 0 /*
634 Return T if point is at the beginning of a line.
635 If BUFFER is nil, the current buffer is assumed.
636 */ )
637 (buffer)
638 Lisp_Object buffer;
639 {
640 struct buffer *b = decode_buffer (buffer, 1);
641
642 return beginning_of_line_p (b, BUF_PT (b)) ? Qt : Qnil;
643 }
644
645 DEFUN ("eolp", Feolp, Seolp, 0, 1, 0 /*
646 Return T if point is at the end of a line.
647 `End of a line' includes point being at the end of the buffer.
648 If BUFFER is nil, the current buffer is assumed.
649 */ )
650 (buffer)
651 Lisp_Object buffer;
652 {
653 struct buffer *b = decode_buffer (buffer, 1);
654 if (BUF_PT (b) == BUF_ZV (b) || BUF_FETCH_CHAR (b, BUF_PT (b)) == '\n')
655 return Qt;
656 return Qnil;
657 }
658
659 DEFUN ("char-after", Fchar_after, Schar_after, 1, 2, 0 /*
660 Return character in BUFFER at position POS.
661 POS is an integer or a buffer pointer.
662 If POS is out of range, the value is nil.
663 If BUFFER is nil, the current buffer is assumed.
664 */ )
665 (pos, buffer)
666 Lisp_Object pos, buffer;
667 {
668 struct buffer *b = decode_buffer (buffer, 1);
669 Bufpos n = get_buffer_pos_char (b, pos, GB_NO_ERROR_IF_BAD);
670
671 if (n < 0 || n == BUF_ZV (b))
672 return Qnil;
673 return (make_char (BUF_FETCH_CHAR (b, n)));
674 }
675
676
677 DEFUN ("user-login-name", Fuser_login_name, Suser_login_name, 0, 1, 0 /*
678 Return the name under which the user logged in, as a string.
679 This is based on the effective uid, not the real uid.
680 Also, if the environment variable LOGNAME or USER is set,
681 that determines the value of this function.
682 If the optional argument UID is present, then environment variables are
683 ignored and this function returns the login name for that UID, or nil.
684 */ )
685 (uid)
686 Lisp_Object uid;
687 {
688 struct passwd *pw = NULL;
689
690 if (!NILP (uid))
691 {
692 CHECK_INT (uid);
693 pw = (struct passwd *) getpwuid (XINT (uid));
694 }
695 else
696 {
697 char *user_name;
698 /* #### - when euid != uid, then LOGNAME and USER are leftovers from the
699 old environment (I site observed behavior on sunos and linux), so the
700 environment variables should be disregarded in that case. --Stig */
701 user_name = getenv ("LOGNAME");
702 if (!user_name)
703 #ifdef WINDOWSNT
704 user_name = (char *) getenv ("USERNAME"); /* it's USERNAME on NT */
705 #else /* WINDOWSNT */
706 user_name = (char *) getenv ("USER");
707 #endif /* WINDOWSNT */
708 if (user_name)
709 return (build_string (user_name));
710 else
711 pw = (struct passwd *) getpwuid (geteuid ());
712 }
713 /* #### - I believe this should return nil instead of "unknown" when pw==0 */
714 return (pw ? build_string (pw->pw_name) : Qnil);
715 }
716
717 DEFUN ("user-real-login-name", Fuser_real_login_name, Suser_real_login_name,
718 0, 0, 0 /*
719 Return the name of the user's real uid, as a string.
720 This ignores the environment variables LOGNAME and USER, so it differs from
721 `user-login-name' when running under `su'.
722 */ )
723 ()
724 {
725 struct passwd *pw = (struct passwd *) getpwuid (getuid ());
726 /* #### - I believe this should return nil instead of "unknown" when pw==0 */
727
728 #ifdef MSDOS
729 /* We let the real user name default to "root" because that's quite
730 accurate on MSDOG and because it lets Emacs find the init file.
731 (The DVX libraries override the Djgpp libraries here.) */
732 Lisp_Object tem = build_string (pw ? pw->pw_name : "root");/* no gettext */
733 #else
734 Lisp_Object tem = build_string (pw ? pw->pw_name : "unknown");/* no gettext */
735 #endif
736 return (tem);
737 }
738
739 DEFUN ("user-uid", Fuser_uid, Suser_uid, 0, 0, 0 /*
740 Return the effective uid of Emacs, as an integer.
741 */ )
742 ()
743 {
744 return make_int (geteuid ());
745 }
746
747 DEFUN ("user-real-uid", Fuser_real_uid, Suser_real_uid, 0, 0, 0 /*
748 Return the real uid of Emacs, as an integer.
749 */ )
750 ()
751 {
752 return make_int (getuid ());
753 }
754
755 DEFUN ("user-full-name", Fuser_full_name, Suser_full_name, 0, 1, 0 /*
756 Return the full name of the user logged in, as a string.
757 If the optional argument USER is given, then the full name for that
758 user is returned, or nil. USER may be either a login name or a uid.
759 */ )
760 (user)
761 Lisp_Object user;
762 {
763 Lisp_Object uname = (STRINGP (user) ? user : Fuser_login_name (user));
764 struct passwd *pw = NULL;
765 Lisp_Object tem;
766 char *p, *q;
767
768 if (!NILP (uname)) /* nil when nonexistent UID passed as arg */
769 {
770 CONST char *uname_ext;
771
772 /* Fuck me. getpwnam() can call select() and (under IRIX at least)
773 things get wedged if a SIGIO arrives during this time. */
774 GET_C_STRING_OS_DATA_ALLOCA (uname, uname_ext);
775 slow_down_interrupts ();
776 pw = (struct passwd *) getpwnam (uname_ext);
777 speed_up_interrupts ();
778 }
779
780 /* #### - Stig sez: this should return nil instead of "unknown" when pw==0 */
781 /* Ben sez: bad idea because it's likely to break something */
782 #ifndef AMPERSAND_FULL_NAME
783 p = (char *) ((pw) ? USER_FULL_NAME : "unknown"); /* don't gettext */
784 q = (char *) strchr ((char *) p, ',');
785 #else
786 p = (char *) ((pw) ? USER_FULL_NAME : "unknown"); /* don't gettext */
787 q = (char *) strchr ((char *) p, ',');
788 #endif
789 tem = ((!NILP (user) && !pw)
790 ? Qnil
791 : make_ext_string ((unsigned char *) p, (q ? q - p : strlen (p)),
792 FORMAT_OS));
793
794 #ifdef AMPERSAND_FULL_NAME
795 if (!NILP (tem))
796 {
797 p = (char *) string_data (XSTRING (tem));
798 q = strchr (p, '&');
799 /* Substitute the login name for the &, upcasing the first character. */
800 if (q)
801 {
802 char *r = (char *) alloca (strlen (p) +
803 string_length (XSTRING (uname)) + 1);
804 memcpy (r, p, q - p);
805 r[q - p] = 0;
806 strcat (r, (char *) string_data (XSTRING (uname)));
807 /* #### current_buffer dependency! */
808 r[q - p] = UPCASE (current_buffer, r[q - p]);
809 strcat (r, q + 1);
810 tem = build_string (r);
811 }
812 }
813 #endif /* AMPERSAND_FULL_NAME */
814
815 p = getenv ("NAME");
816 if (p)
817 tem = build_string (p);
818 return (tem);
819 }
820
821 DEFUN ("system-name", Fsystem_name, Ssystem_name, 0, 0, 0 /*
822 Return the name of the machine you are running on, as a string.
823 */ )
824 ()
825 {
826 return (Fcopy_sequence (Vsystem_name));
827 }
828
829 /* For the benefit of callers who don't want to include lisp.h.
830 Caller must free! */
831 char *
832 get_system_name (void)
833 {
834 return xstrdup ((char *) string_data (XSTRING (Vsystem_name)));
835 }
836
837 DEFUN ("emacs-pid", Femacs_pid, Semacs_pid, 0, 0, 0 /*
838 Return the process ID of Emacs, as an integer.
839 */ )
840 ()
841 {
842 return make_int (getpid ());
843 }
844
845 DEFUN ("current-time", Fcurrent_time, Scurrent_time, 0, 0, 0 /*
846 Return the current time, as the number of seconds since 1970-01-01 00:00:00.
847 The time is returned as a list of three integers. The first has the
848 most significant 16 bits of the seconds, while the second has the
849 least significant 16 bits. The third integer gives the microsecond
850 count.
851
852 The microsecond count is zero on systems that do not provide
853 resolution finer than a second.
854 */ )
855 ()
856 {
857 EMACS_TIME t;
858 Lisp_Object result[3];
859
860 EMACS_GET_TIME (t);
861 XSETINT (result[0], (EMACS_SECS (t) >> 16) & 0xffff);
862 XSETINT (result[1], (EMACS_SECS (t) >> 0) & 0xffff);
863 XSETINT (result[2], EMACS_USECS (t));
864
865 return Flist (3, result);
866 }
867
868 DEFUN ("current-process-time", Fcurrent_process_time, Scurrent_process_time,
869 0, 0, 0 /*
870 Return the amount of time used by this XEmacs process so far.
871 The return value is a list of three floating-point numbers, expressing
872 the user, system, and real times used by the process. The user time
873 measures the time actually spent by the CPU executing the code in this
874 process. The system time measures time spent by the CPU executing kernel
875 code on behalf of this process (e.g. I/O requests made by the process).
876
877 Note that the user and system times measure processor time, as opposed
878 to real time, and only accrue when the processor is actually doing
879 something: Time spent in an idle wait (waiting for user events to come
880 in or for I/O on a disk drive or other device to complete) does not
881 count. Thus, the user and system times will often be considerably
882 less than the real time.
883
884 Some systems do not allow the user and system times to be distinguished.
885 In this case, the user time will be the total processor time used by
886 the process, and the system time will be 0.
887
888 Some systems do not allow the real and processor times to be distinguished.
889 In this case, the user and real times will be the same and the system
890 time will be 0.
891 */ )
892 ()
893 {
894 double user, sys, real;
895
896 get_process_times (&user, &sys, &real);
897 return list3 (make_float (user), make_float (sys), make_float (real));
898 }
899
900
901 int
902 lisp_to_time (Lisp_Object specified_time, time_t *result)
903 {
904 if (NILP (specified_time))
905 return time (result) != -1;
906 else
907 {
908 Lisp_Object high, low;
909 high = Fcar (specified_time);
910 CHECK_INT (high);
911 low = Fcdr (specified_time);
912 if (CONSP (low))
913 low = Fcar (low);
914 CHECK_INT (low);
915 *result = (XINT (high) << 16) + (XINT (low) & 0xffff);
916 return *result >> 16 == XINT (high);
917 }
918 }
919
920 Lisp_Object
921 time_to_lisp (time_t the_time)
922 {
923 unsigned int item = (unsigned int) the_time;
924 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
925 }
926
927 size_t emacs_strftime (char *string, size_t max, CONST char *format,
928 CONST struct tm *tm);
929 static long difftm (CONST struct tm *a, CONST struct tm *b);
930
931
932 DEFUN ("format-time-string", Fformat_time_string, Sformat_time_string,
933 2, 2, 0 /*
934 Use FORMAT-STRING to format the time TIME.
935 TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as from
936 `current-time' and `file-attributes'.
937 FORMAT-STRING may contain %-sequences to substitute parts of the time.
938 %a is replaced by the abbreviated name of the day of week.
939 %A is replaced by the full name of the day of week.
940 %b is replaced by the abbreviated name of the month.
941 %B is replaced by the full name of the month.
942 %c is a synonym for \"%x %X\".
943 %C is a locale-specific synonym, which defaults to \"%A, %B %e, %Y\" in the C locale.
944 %d is replaced by the day of month, zero-padded.
945 %D is a synonym for \"%m/%d/%y\".
946 %e is replaced by the day of month, blank-padded.
947 %h is a synonym for \"%b\".
948 %H is replaced by the hour (00-23).
949 %I is replaced by the hour (00-12).
950 %j is replaced by the day of the year (001-366).
951 %k is replaced by the hour (0-23), blank padded.
952 %l is replaced by the hour (1-12), blank padded.
953 %m is replaced by the month (01-12).
954 %M is replaced by the minute (00-59).
955 %n is a synonym for \"\\n\".
956 %p is replaced by AM or PM, as appropriate.
957 %r is a synonym for \"%I:%M:%S %p\".
958 %R is a synonym for \"%H:%M\".
959 %S is replaced by the second (00-60).
960 %t is a synonym for \"\\t\".
961 %T is a synonym for \"%H:%M:%S\".
962 %U is replaced by the week of the year (00-53), first day of week is Sunday.
963 %w is replaced by the day of week (0-6), Sunday is day 0.
964 %W is replaced by the week of the year (00-53), first day of week is Monday.
965 %x is a locale-specific synonym, which defaults to \"%D\" in the C locale.
966 %X is a locale-specific synonym, which defaults to \"%T\" in the C locale.
967 %y is replaced by the year without century (00-99).
968 %Y is replaced by the year with century.
969 %Z is replaced by the time zone abbreviation.
970
971 The number of options reflects the `strftime' function.
972
973 BUG: If the charset used by the current locale is not ISO 8859-1, the
974 characters appearing in the day and month names may be incorrect.
975 */ )
976 (format_string, _time)
977 Lisp_Object format_string, _time;
978 {
979 time_t value;
980 int size;
981
982 CHECK_STRING (format_string);
983
984 if (! lisp_to_time (_time, &value))
985 error ("Invalid time specification");
986
987 /* This is probably enough. */
988 size = string_length (XSTRING (format_string)) * 6 + 50;
989
990 while (1)
991 {
992 char *buf = (char *) alloca (size);
993 *buf = 1;
994 if (emacs_strftime (buf, size,
995 (CONST char *) string_data (XSTRING (format_string)),
996 localtime (&value))
997 || !*buf)
998 return build_ext_string (buf, FORMAT_BINARY);
999 /* If buffer was too small, make it bigger. */
1000 size *= 2;
1001 }
1002 }
1003
1004 DEFUN ("decode-time", Fdecode_time, Sdecode_time, 0, 1, 0 /*
1005 Decode a time value as (SEC MINUTE HOUR DAY MONTH YEAR DOW DST ZONE).
1006 The optional SPECIFIED-TIME should be a list of (HIGH LOW . IGNORED)
1007 or (HIGH . LOW), as from `current-time' and `file-attributes', or `nil'
1008 to use the current time. The list has the following nine members:
1009 SEC is an integer between 0 and 60; SEC is 60 for a leap second, which
1010 only some operating systems support. MINUTE is an integer between 0 and 59.
1011 HOUR is an integer between 0 and 23. DAY is an integer between 1 and 31.
1012 MONTH is an integer between 1 and 12. YEAR is an integer indicating the
1013 four-digit year. DOW is the day of week, an integer between 0 and 6, where
1014 0 is Sunday. DST is t if daylight savings time is effect, otherwise nil.
1015 ZONE is an integer indicating the number of seconds east of Greenwich.
1016 \(Note that Common Lisp has different meanings for DOW and ZONE.)
1017 */ )
1018 (specified_time)
1019 Lisp_Object specified_time;
1020 {
1021 time_t time_spec;
1022 struct tm save_tm;
1023 struct tm *decoded_time;
1024 Lisp_Object list_args[9];
1025
1026 if (! lisp_to_time (specified_time, &time_spec))
1027 error ("Invalid time specification");
1028
1029 decoded_time = localtime (&time_spec);
1030 XSETINT (list_args[0], decoded_time->tm_sec);
1031 XSETINT (list_args[1], decoded_time->tm_min);
1032 XSETINT (list_args[2], decoded_time->tm_hour);
1033 XSETINT (list_args[3], decoded_time->tm_mday);
1034 XSETINT (list_args[4], decoded_time->tm_mon + 1);
1035 XSETINT (list_args[5], decoded_time->tm_year + 1900);
1036 XSETINT (list_args[6], decoded_time->tm_wday);
1037 list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil;
1038
1039 /* Make a copy, in case gmtime modifies the struct. */
1040 save_tm = *decoded_time;
1041 decoded_time = gmtime (&time_spec);
1042 if (decoded_time == 0)
1043 list_args[8] = Qnil;
1044 else
1045 XSETINT (list_args[8], difftm (&save_tm, decoded_time));
1046 return Flist (9, list_args);
1047 }
1048
1049 static void set_time_zone_rule (char *tzstring);
1050
1051 DEFUN ("encode-time", Fencode_time, Sencode_time, 6, MANY, 0 /*
1052 Convert SECOND, MINUTE, HOUR, DAY, MONTH, YEAR and ZONE to internal time.
1053 This is the reverse operation of `decode-time', which see.
1054 ZONE defaults to the current time zone rule. This can
1055 be a string (as from `set-time-zone-rule'), or it can be a list
1056 (as from `current-time-zone') or an integer (as from `decode-time')
1057 applied without consideration for daylight savings time.
1058
1059 You can pass more than 7 arguments; then the first six arguments
1060 are used as SECOND through YEAR, and the *last* argument is used as ZONE.
1061 The intervening arguments are ignored.
1062 This feature lets (apply 'encode-time (decode-time ...)) work.
1063
1064 Out-of-range values for SEC, MINUTE, HOUR, DAY, or MONTH are allowed;
1065 for example, a DAY of 0 means the day preceding the given month.
1066 Year numbers less than 100 are treated just like other year numbers.
1067 If you want them to stand for years in this century, you must do that yourself
1068 */ )
1069 (nargs, args)
1070 int nargs;
1071 Lisp_Object *args;
1072 {
1073 time_t _time;
1074 struct tm tm;
1075 Lisp_Object zone = (nargs > 6) ? args[nargs - 1] : Qnil;
1076
1077 CHECK_INT (args[0]); /* second */
1078 CHECK_INT (args[1]); /* minute */
1079 CHECK_INT (args[2]); /* hour */
1080 CHECK_INT (args[3]); /* day */
1081 CHECK_INT (args[4]); /* month */
1082 CHECK_INT (args[5]); /* year */
1083
1084 tm.tm_sec = XINT (args[0]);
1085 tm.tm_min = XINT (args[1]);
1086 tm.tm_hour = XINT (args[2]);
1087 tm.tm_mday = XINT (args[3]);
1088 tm.tm_mon = XINT (args[4]) - 1;
1089 tm.tm_year = XINT (args[5]) - 1900;
1090 tm.tm_isdst = -1;
1091
1092 if (CONSP (zone))
1093 zone = Fcar (zone);
1094 if (NILP (zone))
1095 _time = mktime (&tm);
1096 else
1097 {
1098 char tzbuf[100];
1099 char *tzstring;
1100 char **oldenv = environ, **newenv;
1101
1102 if (STRINGP (zone))
1103 tzstring = (char *) string_data (XSTRING (zone));
1104 else if (INTP (zone))
1105 {
1106 int abszone = abs (XINT (zone));
1107 sprintf (tzbuf, "XXX%s%d:%02d:%02d", "-" + (XINT (zone) < 0),
1108 abszone / (60*60), (abszone/60) % 60, abszone % 60);
1109 tzstring = tzbuf;
1110 }
1111 else
1112 error ("Invalid time zone specification");
1113
1114 /* Set TZ before calling mktime; merely adjusting mktime's returned
1115 value doesn't suffice, since that would mishandle leap seconds. */
1116 set_time_zone_rule (tzstring);
1117
1118 _time = mktime (&tm);
1119
1120 /* Restore TZ to previous value. */
1121 newenv = environ;
1122 environ = oldenv;
1123 free (newenv);
1124 #ifdef LOCALTIME_CACHE
1125 tzset ();
1126 #endif
1127 }
1128
1129 if (_time == (time_t) -1)
1130 error ("Specified time is not representable");
1131
1132 return wasteful_word_to_lisp (_time);
1133 }
1134
1135 DEFUN ("current-time-string", Fcurrent_time_string, Scurrent_time_string,
1136 0, 1, 0 /*
1137 Return the current time, as a human-readable string.
1138 Programs can use this function to decode a time,
1139 since the number of columns in each field is fixed.
1140 The format is `Sun Sep 16 01:03:52 1973'.
1141 If an argument is given, it specifies a time to format
1142 instead of the current time. The argument should have the form:
1143 (HIGH . LOW)
1144 or the form:
1145 (HIGH LOW . IGNORED).
1146 Thus, you can use times obtained from `current-time'
1147 and from `file-attributes'.
1148 */ )
1149 (specified_time)
1150 Lisp_Object specified_time;
1151 {
1152 time_t value;
1153 char buf[30];
1154 char *tem;
1155
1156 if (! lisp_to_time (specified_time, &value))
1157 value = -1;
1158 tem = (char *) ctime (&value);
1159
1160 strncpy (buf, tem, 24);
1161 buf[24] = 0;
1162
1163 return build_ext_string (buf, FORMAT_BINARY);
1164 }
1165
1166 #define TM_YEAR_ORIGIN 1900
1167
1168 /* Yield A - B, measured in seconds. */
1169 static long
1170 difftm (CONST struct tm *a, CONST struct tm *b)
1171 {
1172 int ay = a->tm_year + (TM_YEAR_ORIGIN - 1);
1173 int by = b->tm_year + (TM_YEAR_ORIGIN - 1);
1174 /* Some compilers can't handle this as a single return statement. */
1175 long days = (
1176 /* difference in day of year */
1177 a->tm_yday - b->tm_yday
1178 /* + intervening leap days */
1179 + ((ay >> 2) - (by >> 2))
1180 - (ay/100 - by/100)
1181 + ((ay/100 >> 2) - (by/100 >> 2))
1182 /* + difference in years * 365 */
1183 + (long)(ay-by) * 365
1184 );
1185 return (60*(60*(24*days + (a->tm_hour - b->tm_hour))
1186 + (a->tm_min - b->tm_min))
1187 + (a->tm_sec - b->tm_sec));
1188 }
1189
1190 DEFUN ("current-time-zone", Fcurrent_time_zone, Scurrent_time_zone, 0, 1, 0 /*
1191 Return the offset and name for the local time zone.
1192 This returns a list of the form (OFFSET NAME).
1193 OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
1194 A negative value means west of Greenwich.
1195 NAME is a string giving the name of the time zone.
1196 If an argument is given, it specifies when the time zone offset is determined
1197 instead of using the current time. The argument should have the form:
1198 (HIGH . LOW)
1199 or the form:
1200 (HIGH LOW . IGNORED).
1201 Thus, you can use times obtained from `current-time'
1202 and from `file-attributes'.
1203
1204 Some operating systems cannot provide all this information to Emacs;
1205 in this case, `current-time-zone' returns a list containing nil for
1206 the data it can't find.
1207 */ )
1208 (specified_time)
1209 Lisp_Object specified_time;
1210 {
1211 time_t value;
1212 struct tm *t;
1213
1214 if (lisp_to_time (specified_time, &value)
1215 && (t = gmtime (&value)) != 0)
1216 {
1217 struct tm gmt;
1218 long offset;
1219 char *s, buf[6];
1220
1221 gmt = *t; /* Make a copy, in case localtime modifies *t. */
1222 t = localtime (&value);
1223 offset = difftm (t, &gmt);
1224 s = 0;
1225 #ifdef HAVE_TM_ZONE
1226 if (t->tm_zone)
1227 s = (char *)t->tm_zone;
1228 #else /* not HAVE_TM_ZONE */
1229 #ifdef HAVE_TZNAME
1230 if (t->tm_isdst == 0 || t->tm_isdst == 1)
1231 s = tzname[t->tm_isdst];
1232 #endif
1233 #endif /* not HAVE_TM_ZONE */
1234 if (!s)
1235 {
1236 /* No local time zone name is available; use "+-NNNN" instead. */
1237 int am = (offset < 0 ? -offset : offset) / 60;
1238 sprintf (buf, "%c%02d%02d", (offset < 0 ? '-' : '+'), am/60, am%60);
1239 s = buf;
1240 }
1241 return list2 (make_int (offset), build_string (s));
1242 }
1243 else
1244 return list2 (Qnil, Qnil);
1245 }
1246
1247 /* Set the local time zone rule to TZSTRING.
1248 This allocates memory into `environ', which it is the caller's
1249 responsibility to free. */
1250 static void
1251 set_time_zone_rule (char *tzstring)
1252 {
1253 int envptrs;
1254 char **from, **to, **newenv;
1255
1256 for (from = environ; *from; from++)
1257 continue;
1258 envptrs = from - environ + 2;
1259 newenv = to = (char **) xmalloc (envptrs * sizeof (char *)
1260 + (tzstring ? strlen (tzstring) + 4 : 0));
1261 if (tzstring)
1262 {
1263 char *t = (char *) (to + envptrs);
1264 strcpy (t, "TZ=");
1265 strcat (t, tzstring);
1266 *to++ = t;
1267 }
1268
1269 for (from = environ; *from; from++)
1270 if (strncmp (*from, "TZ=", 3) != 0)
1271 *to++ = *from;
1272 *to = 0;
1273
1274 environ = newenv;
1275
1276 #ifdef LOCALTIME_CACHE
1277 tzset ();
1278 #endif
1279 }
1280
1281 DEFUN ("set-time-zone-rule", Fset_time_zone_rule, Sset_time_zone_rule,
1282 1, 1, 0 /*
1283 Set the local time zone using TZ, a string specifying a time zone rule.
1284 If TZ is nil, use implementation-defined default time zone information.
1285 */ )
1286 (tz)
1287 Lisp_Object tz;
1288 {
1289 char *tzstring;
1290
1291 if (NILP (tz))
1292 tzstring = 0;
1293 else
1294 {
1295 CHECK_STRING (tz);
1296 tzstring = (char *) string_data (XSTRING (tz));
1297 }
1298
1299 set_time_zone_rule (tzstring);
1300 if (environbuf)
1301 xfree (environbuf);
1302 environbuf = environ;
1303
1304 return Qnil;
1305 }
1306
1307
1308 void
1309 buffer_insert1 (struct buffer *buf, Lisp_Object arg)
1310 {
1311 /* This function can GC */
1312 struct gcpro gcpro1;
1313 GCPRO1 (arg);
1314 retry:
1315 if (CHAR_OR_CHAR_INTP (arg))
1316 {
1317 buffer_insert_emacs_char (buf, XCHAR_OR_CHAR_INT (arg));
1318 }
1319 else if (STRINGP (arg))
1320 {
1321 buffer_insert_lisp_string (buf, arg);
1322 }
1323 else
1324 {
1325 arg = wrong_type_argument (Qchar_or_string_p, arg);
1326 goto retry;
1327 }
1328 zmacs_region_stays = 0;
1329 UNGCPRO;
1330 }
1331
1332
1333 /* Callers passing one argument to Finsert need not gcpro the
1334 argument "array", since the only element of the array will
1335 not be used after calling insert_emacs_char or insert_lisp_string,
1336 so we don't care if it gets trashed. */
1337
1338 DEFUN ("insert", Finsert, Sinsert, 0, MANY, 0 /*
1339 Insert the arguments, either strings or characters, at point.
1340 Point moves forward so that it ends up after the inserted text.
1341 Any other markers at the point of insertion remain before the text.
1342 If a string has non-null string-extent-data, new extents will be created.
1343 */ )
1344 (nargs, args)
1345 int nargs;
1346 Lisp_Object *args;
1347 {
1348 /* This function can GC */
1349 REGISTER int argnum;
1350
1351 for (argnum = 0; argnum < nargs; argnum++)
1352 {
1353 buffer_insert1 (current_buffer, args[argnum]);
1354 }
1355
1356 return Qnil;
1357 }
1358
1359 DEFUN ("insert-before-markers", Finsert_before_markers, Sinsert_before_markers, 0, MANY, 0 /*
1360 Insert strings or characters at point, relocating markers after the text.
1361 Point moves forward so that it ends up after the inserted text.
1362 Any other markers at the point of insertion also end up after the text.
1363 */ )
1364 (nargs, args)
1365 int nargs;
1366 Lisp_Object *args;
1367 {
1368 /* This function can GC */
1369 REGISTER int argnum;
1370 REGISTER Lisp_Object tem;
1371
1372 for (argnum = 0; argnum < nargs; argnum++)
1373 {
1374 tem = args[argnum];
1375 retry:
1376 if (CHAR_OR_CHAR_INTP (tem))
1377 {
1378 buffer_insert_emacs_char_1 (current_buffer, -1,
1379 XCHAR_OR_CHAR_INT (tem),
1380 INSDEL_BEFORE_MARKERS);
1381 }
1382 else if (STRINGP (tem))
1383 {
1384 buffer_insert_lisp_string_1 (current_buffer, -1, tem,
1385 INSDEL_BEFORE_MARKERS);
1386 }
1387 else
1388 {
1389 tem = wrong_type_argument (Qchar_or_string_p, tem);
1390 goto retry;
1391 }
1392 }
1393 zmacs_region_stays = 0;
1394 return Qnil;
1395 }
1396
1397 DEFUN ("insert-string", Finsert_string, Sinsert_string, 1, 2, 0 /*
1398 Insert STRING into BUFFER at BUFFER's point.
1399 Point moves forward so that it ends up after the inserted text.
1400 Any other markers at the point of insertion remain before the text.
1401 If a string has non-null string-extent-data, new extents will be created.
1402 BUFFER defaults to the current buffer.
1403 */ )
1404 (string, buffer)
1405 Lisp_Object string, buffer;
1406 {
1407 struct buffer *buf = decode_buffer (buffer, 1);
1408 CHECK_STRING (string);
1409 buffer_insert_lisp_string (buf, string);
1410 zmacs_region_stays = 0;
1411 return Qnil;
1412 }
1413
1414 /* Third argument in FSF is INHERIT:
1415
1416 "The optional third arg INHERIT, if non-nil, says to inherit text properties\n\
1417 from adjoining text, if those properties are sticky."
1418
1419 Jamie thinks this is bogus. */
1420
1421
1422 DEFUN ("insert-char", Finsert_char, Sinsert_char, 1, 4, 0 /*
1423 Insert COUNT (second arg) copies of CHR (first arg).
1424 Point and all markers are affected as in the function `insert'.
1425 COUNT defaults to 1 if omitted.
1426 The optional third arg IGNORED is INHERIT under FSF Emacs.
1427 This is highly bogus, however, and XEmacs always behaves as if
1428 `t' were passed to INHERIT.
1429 The optional fourth arg BUFFER specifies the buffer to insert the
1430 text into. If BUFFER is nil, the current buffer is assumed.
1431 */ )
1432 (chr, count, ignored, buffer)
1433 Lisp_Object chr, count, ignored, buffer;
1434 {
1435 /* This function can GC */
1436 REGISTER Bufbyte *string;
1437 REGISTER int slen;
1438 REGISTER int i, j;
1439 REGISTER Bytecount n;
1440 REGISTER Bytecount charlen;
1441 Bufbyte str[MAX_EMCHAR_LEN];
1442 struct buffer *buf = decode_buffer (buffer, 1);
1443 int cou;
1444
1445 CHECK_CHAR_COERCE_INT (chr);
1446 if (NILP (count))
1447 cou = 1;
1448 else
1449 {
1450 CHECK_INT (count);
1451 cou = XINT (count);
1452 }
1453
1454 charlen = set_charptr_emchar (str, XCHAR (chr));
1455 n = cou * charlen;
1456 if (n <= 0)
1457 return Qnil;
1458 slen = min (n, 768);
1459 string = (Bufbyte *) alloca (slen * sizeof (Bufbyte));
1460 /* Write as many copies of the character into the temp string as will fit. */
1461 for (i = 0; i + charlen <= slen; i += charlen)
1462 for (j = 0; j < charlen; j++)
1463 string[i + j] = str[j];
1464 slen = i;
1465 while (n >= slen)
1466 {
1467 buffer_insert_raw_string (buf, string, slen);
1468 n -= slen;
1469 }
1470 if (n > 0)
1471 #if 0 /* FSFmacs bogosity */
1472 {
1473 if (!NILP (inherit))
1474 insert_and_inherit (string, n);
1475 else
1476 insert (string, n);
1477 }
1478 #else
1479 buffer_insert_raw_string (buf, string, n);
1480 #endif
1481
1482 zmacs_region_stays = 0;
1483 return Qnil;
1484 }
1485
1486
1487 /* Making strings from buffer contents. */
1488
1489 DEFUN ("buffer-substring", Fbuffer_substring, Sbuffer_substring, 0, 3, 0 /*
1490 Return the contents of part of BUFFER as a string.
1491 The two arguments START and END are character positions;
1492 they can be in either order. If omitted, they default to the beginning
1493 and end of BUFFER, respectively.
1494 If there are duplicable extents in the region, the string remembers
1495 them in its extent data.
1496 If BUFFER is nil, the current buffer is assumed.
1497 */ )
1498 (start, end, buffer)
1499 Lisp_Object start, end, buffer;
1500 {
1501 /* This function can GC */
1502 Bufpos begv, zv;
1503 struct buffer *b = decode_buffer (buffer, 1);
1504
1505 get_buffer_range_char (b, start, end, &begv, &zv, GB_ALLOW_NIL);
1506 return make_string_from_buffer (b, begv, zv - begv);
1507 }
1508
1509 DEFUN ("insert-buffer-substring", Finsert_buffer_substring, Sinsert_buffer_substring,
1510 1, 3, 0 /*
1511 Insert before point a substring of the contents of buffer BUFFER.
1512 BUFFER may be a buffer or a buffer name.
1513 Arguments START and END are character numbers specifying the substring.
1514 They default to the beginning and the end of BUFFER.
1515 */ )
1516 (buffer, start, end)
1517 Lisp_Object buffer, start, end;
1518 {
1519 /* This function can GC */
1520 Bufpos b, e;
1521 struct buffer *bp;
1522
1523 bp = XBUFFER (get_buffer (buffer, 1));
1524 get_buffer_range_char (bp, start, end, &b, &e, GB_ALLOW_NIL);
1525
1526 if (b < e)
1527 buffer_insert_from_buffer (current_buffer, bp, b, e - b);
1528
1529 return Qnil;
1530 }
1531
1532 DEFUN ("compare-buffer-substrings", Fcompare_buffer_substrings, Scompare_buffer_substrings,
1533 6, 6, 0 /*
1534 Compare two substrings of two buffers; return result as number.
1535 the value is -N if first string is less after N-1 chars,
1536 +N if first string is greater after N-1 chars, or 0 if strings match.
1537 Each substring is represented as three arguments: BUFFER, START and END.
1538 That makes six args in all, three for each substring.
1539
1540 The value of `case-fold-search' in the current buffer
1541 determines whether case is significant or ignored.
1542 */ )
1543 (buffer1, start1, end1, buffer2, start2, end2)
1544 Lisp_Object buffer1, start1, end1, buffer2, start2, end2;
1545 {
1546 Bufpos begp1, endp1, begp2, endp2;
1547 REGISTER Charcount len1, len2, length, i;
1548 struct buffer *bp1, *bp2;
1549 Lisp_Object trt = ((!NILP (current_buffer->case_fold_search)) ?
1550 current_buffer->case_canon_table : Qnil);
1551
1552 /* Find the first buffer and its substring. */
1553
1554 bp1 = decode_buffer (buffer1, 1);
1555 get_buffer_range_char (bp1, start1, end1, &begp1, &endp1, GB_ALLOW_NIL);
1556
1557 /* Likewise for second substring. */
1558
1559 bp2 = decode_buffer (buffer2, 1);
1560 get_buffer_range_char (bp2, start2, end2, &begp2, &endp2, GB_ALLOW_NIL);
1561
1562 len1 = endp1 - begp1;
1563 len2 = endp2 - begp2;
1564 length = len1;
1565 if (len2 < length)
1566 length = len2;
1567
1568 for (i = 0; i < length; i++)
1569 {
1570 Emchar c1 = BUF_FETCH_CHAR (bp1, begp1 + i);
1571 Emchar c2 = BUF_FETCH_CHAR (bp2, begp2 + i);
1572 if (!NILP (trt))
1573 {
1574 c1 = TRT_TABLE_OF (trt, c1);
1575 c2 = TRT_TABLE_OF (trt, c2);
1576 }
1577 if (c1 < c2)
1578 return make_int (- 1 - i);
1579 if (c1 > c2)
1580 return make_int (i + 1);
1581 }
1582
1583 /* The strings match as far as they go.
1584 If one is shorter, that one is less. */
1585 if (length < len1)
1586 return make_int (length + 1);
1587 else if (length < len2)
1588 return make_int (- length - 1);
1589
1590 /* Same length too => they are equal. */
1591 return Qzero;
1592 }
1593
1594
1595 static Lisp_Object
1596 subst_char_in_region_unwind (Lisp_Object arg)
1597 {
1598 XBUFFER (XCAR (arg))->undo_list = XCDR (arg);
1599 return Qnil;
1600 }
1601
1602 static Lisp_Object
1603 subst_char_in_region_unwind_1 (Lisp_Object arg)
1604 {
1605 XBUFFER (XCAR (arg))->filename = XCDR (arg);
1606 return Qnil;
1607 }
1608
1609 DEFUN ("subst-char-in-region", Fsubst_char_in_region,
1610 Ssubst_char_in_region, 4, 5, 0 /*
1611 From START to END, replace FROMCHAR with TOCHAR each time it occurs.
1612 If optional arg NOUNDO is non-nil, don't record this change for undo
1613 and don't mark the buffer as really changed.
1614 */ )
1615 (start, end, fromchar, tochar, noundo)
1616 Lisp_Object start, end, fromchar, tochar, noundo;
1617 {
1618 /* This function can GC */
1619 Bufpos pos, stop;
1620 Emchar fromc, toc;
1621 int mc_count;
1622 struct buffer *buf = current_buffer;
1623 int count = specpdl_depth ();
1624
1625 get_buffer_range_char (buf, start, end, &pos, &stop, 0);
1626 CHECK_CHAR_COERCE_INT (fromchar);
1627 CHECK_CHAR_COERCE_INT (tochar);
1628
1629 fromc = XCHAR (fromchar);
1630 toc = XCHAR (tochar);
1631
1632 /* If we don't want undo, turn off putting stuff on the list.
1633 That's faster than getting rid of things,
1634 and it prevents even the entry for a first change.
1635 Also inhibit locking the file. */
1636 if (!NILP (noundo))
1637 {
1638 record_unwind_protect (subst_char_in_region_unwind,
1639 Fcons (Fcurrent_buffer (), buf->undo_list));
1640 buf->undo_list = Qt;
1641 /* Don't do file-locking. */
1642 record_unwind_protect (subst_char_in_region_unwind_1,
1643 Fcons (Fcurrent_buffer (), buf->filename));
1644 buf->filename = Qnil;
1645 }
1646
1647 mc_count = begin_multiple_change (buf, pos, stop);
1648 while (pos < stop)
1649 {
1650 if (BUF_FETCH_CHAR (buf, pos) == fromc)
1651 {
1652 /* There used to be some code here that set the buffer to
1653 unmodified if NOUNDO was specified and there was only
1654 one change to the buffer since it was last saved.
1655 This is a crock of shit, so I'm not duplicating this
1656 behavior. I think this was left over from when
1657 prepare_to_modify_buffer() actually bumped MODIFF,
1658 so that code was supposed to undo this change. --ben */
1659 buffer_replace_char (buf, pos, toc, !NILP (noundo), 0);
1660
1661 /* If noundo is not nil then we don't mark the buffer as
1662 modified. In reality that needs to happen externally
1663 only. Internally redisplay needs to know that the actual
1664 contents it should be displaying have changed. */
1665 if (!NILP (noundo))
1666 Fset_buffer_modified_p (Fbuffer_modified_p (Qnil), Qnil);
1667 }
1668 pos++;
1669 }
1670 end_multiple_change (buf, mc_count);
1671
1672 unbind_to (count, Qnil);
1673 return Qnil;
1674 }
1675
1676 DEFUN ("translate-region", Ftranslate_region, Stranslate_region, 3, 3, 0 /*
1677 From START to END, translate characters according to TABLE.
1678 TABLE is a string; the Nth character in it is the mapping
1679 for the character with code N. Returns the number of characters changed.
1680 */ )
1681 (start, end, table)
1682 Lisp_Object start;
1683 Lisp_Object end;
1684 Lisp_Object table;
1685 {
1686 /* This function can GC */
1687 Bufpos pos, stop; /* Limits of the region. */
1688 REGISTER Emchar oc; /* Old character. */
1689 REGISTER Emchar nc; /* New character. */
1690 int cnt; /* Number of changes made. */
1691 Charcount size; /* Size of translate table. */
1692 int mc_count;
1693 struct buffer *buf = current_buffer;
1694
1695 get_buffer_range_char (buf, start, end, &pos, &stop, 0);
1696 CHECK_STRING (table);
1697
1698 size = string_char_length (XSTRING (table));
1699
1700 cnt = 0;
1701 mc_count = begin_multiple_change (buf, pos, stop);
1702 for (; pos < stop; pos++)
1703 {
1704 oc = BUF_FETCH_CHAR (buf, pos);
1705 if (oc >= 0 && oc < size)
1706 {
1707 nc = string_char (XSTRING (table), oc);
1708 if (nc != oc)
1709 {
1710 buffer_replace_char (buf, pos, nc, 0, 0);
1711 ++cnt;
1712 }
1713 }
1714 }
1715 end_multiple_change (buf, mc_count);
1716
1717 return make_int (cnt);
1718 }
1719
1720 DEFUN ("delete-region", Fdelete_region, Sdelete_region, 2, 3, "r" /*
1721 Delete the text between point and mark.
1722 When called from a program, expects two arguments,
1723 positions (integers or markers) specifying the stretch to be deleted.
1724 If BUFFER is nil, the current buffer is assumed.
1725 */ )
1726 (b, e, buffer)
1727 Lisp_Object b, e, buffer;
1728 {
1729 /* This function can GC */
1730 Bufpos start, end;
1731 struct buffer *buf = decode_buffer (buffer, 1);
1732
1733 get_buffer_range_char (buf, b, e, &start, &end, 0);
1734 buffer_delete_range (buf, start, end, 0);
1735 zmacs_region_stays = 0;
1736 return Qnil;
1737 }
1738
1739 void
1740 widen_buffer (struct buffer *b, int no_clip)
1741 {
1742 if (BUF_BEGV (b) != BUF_BEG (b))
1743 {
1744 clip_changed = 1;
1745 SET_BOTH_BUF_BEGV (b, BUF_BEG (b), BI_BUF_BEG (b));
1746 }
1747 if (BUF_ZV (b) != BUF_Z (b))
1748 {
1749 clip_changed = 1;
1750 SET_BOTH_BUF_ZV (b, BUF_Z (b), BI_BUF_Z (b));
1751 }
1752 if (clip_changed)
1753 {
1754 if (!no_clip)
1755 MARK_CLIP_CHANGED;
1756 /* Changing the buffer bounds invalidates any recorded current
1757 column. */
1758 invalidate_current_column ();
1759 }
1760 }
1761
1762 DEFUN ("widen", Fwiden, Swiden, 0, 1, "" /*
1763 Remove restrictions (narrowing) from BUFFER.
1764 This allows the buffer's full text to be seen and edited.
1765 If BUFFER is nil, the current buffer is assumed.
1766 */ )
1767 (buffer)
1768 Lisp_Object buffer;
1769 {
1770 struct buffer *b = decode_buffer (buffer, 1);
1771 widen_buffer (b, 0);
1772 zmacs_region_stays = 0;
1773 return Qnil;
1774 }
1775
1776 DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 3, "r" /*
1777 Restrict editing in BUFFER to the current region.
1778 The rest of the text becomes temporarily invisible and untouchable
1779 but is not deleted; if you save the buffer in a file, the invisible
1780 text is included in the file. \\[widen] makes all visible again.
1781 If BUFFER is nil, the current buffer is assumed.
1782 See also `save-restriction'.
1783
1784 When calling from a program, pass two arguments; positions (integers
1785 or markers) bounding the text that should remain visible.
1786 */ )
1787 (b, e, buffer)
1788 Lisp_Object b, e, buffer;
1789 {
1790 Bufpos start, end;
1791 struct buffer *buf = decode_buffer (buffer, 1);
1792 Bytind bi_start, bi_end;
1793
1794 get_buffer_range_char (buf, b, e, &start, &end, GB_ALLOW_PAST_ACCESSIBLE);
1795 bi_start = bufpos_to_bytind (buf, start);
1796 bi_end = bufpos_to_bytind (buf, end);
1797
1798 SET_BOTH_BUF_BEGV (buf, start, bi_start);
1799 SET_BOTH_BUF_ZV (buf, end, bi_end);
1800 if (BUF_PT (buf) < start)
1801 BUF_SET_PT (buf, start);
1802 if (BUF_PT (buf) > end)
1803 BUF_SET_PT (buf, end);
1804 MARK_CLIP_CHANGED;
1805 /* Changing the buffer bounds invalidates any recorded current column. */
1806 invalidate_current_column ();
1807 zmacs_region_stays = 0;
1808 return Qnil;
1809 }
1810
1811 Lisp_Object
1812 save_restriction_save (void)
1813 {
1814 Lisp_Object bottom, top;
1815 /* Note: I tried using markers here, but it does not win
1816 because insertion at the end of the saved region
1817 does not advance mh and is considered "outside" the saved region. */
1818 bottom = make_int (BUF_BEGV (current_buffer) - BUF_BEG (current_buffer));
1819 top = make_int (BUF_Z (current_buffer) - BUF_ZV (current_buffer));
1820
1821 return noseeum_cons (Fcurrent_buffer (), noseeum_cons (bottom, top));
1822 }
1823
1824 Lisp_Object
1825 save_restriction_restore (Lisp_Object data)
1826 {
1827 struct buffer *buf;
1828 Charcount newhead, newtail;
1829 Lisp_Object tem;
1830 int local_clip_changed = 0;
1831
1832 buf = XBUFFER (Fcar (data));
1833 if (!BUFFER_LIVE_P (buf))
1834 /* someone could have killed the buffer in the meantime ... */
1835 return Qnil;
1836 tem = Fcdr (data);
1837 newhead = XINT (Fcar (tem));
1838 newtail = XINT (Fcdr (tem));
1839 while (CONSP (data))
1840 {
1841 struct Lisp_Cons *victim = XCONS (data);
1842 data = victim->cdr;
1843 free_cons (victim);
1844 }
1845
1846 if (newhead + newtail > BUF_Z (buf) - BUF_BEG (buf))
1847 {
1848 newhead = 0;
1849 newtail = 0;
1850 }
1851 {
1852 Bufpos start, end;
1853 Bytind bi_start, bi_end;
1854
1855 start = BUF_BEG (buf) + newhead;
1856 end = BUF_Z (buf) - newtail;
1857
1858 bi_start = bufpos_to_bytind (buf, start);
1859 bi_end = bufpos_to_bytind (buf, end);
1860
1861 if (BUF_BEGV (buf) != start)
1862 {
1863 local_clip_changed = 1;
1864 SET_BOTH_BUF_BEGV (buf, start, bi_start);
1865 }
1866 if (BUF_ZV (buf) != end)
1867 {
1868 local_clip_changed = 1;
1869 SET_BOTH_BUF_ZV (buf, end, bi_end);
1870 }
1871 }
1872 if (local_clip_changed)
1873 MARK_CLIP_CHANGED;
1874
1875 /* If point is outside the new visible range, move it inside. */
1876 BUF_SET_PT (buf,
1877 bufpos_clip_to_bounds (BUF_BEGV (buf),
1878 BUF_PT (buf),
1879 BUF_ZV (buf)));
1880
1881 return Qnil;
1882 }
1883
1884 DEFUN ("save-restriction", Fsave_restriction, Ssave_restriction, 0, UNEVALLED, 0 /*
1885 Execute BODY, saving and restoring current buffer's restrictions.
1886 The buffer's restrictions make parts of the beginning and end invisible.
1887 \(They are set up with `narrow-to-region' and eliminated with `widen'.)
1888 This special form, `save-restriction', saves the current buffer's restrictions
1889 when it is entered, and restores them when it is exited.
1890 So any `narrow-to-region' within BODY lasts only until the end of the form.
1891 The old restrictions settings are restored
1892 even in case of abnormal exit (throw or error).
1893
1894 The value returned is the value of the last form in BODY.
1895
1896 `save-restriction' can get confused if, within the BODY, you widen
1897 and then make changes outside the area within the saved restrictions.
1898
1899 Note: if you are using both `save-excursion' and `save-restriction',
1900 use `save-excursion' outermost:
1901 (save-excursion (save-restriction ...))
1902 */ )
1903 (body)
1904 Lisp_Object body;
1905 {
1906 /* This function can GC */
1907 int speccount = specpdl_depth ();
1908
1909 record_unwind_protect (save_restriction_restore, save_restriction_save ());
1910
1911 return unbind_to (speccount, Fprogn (body));
1912 }
1913
1914
1915 DEFUN ("format", Fformat, Sformat, 1, MANY, 0 /*
1916 Format a string out of a control-string and arguments.
1917 The first argument is a control string.
1918 The other arguments are substituted into it to make the result, a string.
1919 It may contain %-sequences meaning to substitute the next argument.
1920 %s means print all objects as-is, using `princ'.
1921 %S means print all objects as s-expressions, using `prin1'.
1922 %d or %i means print as an integer in decimal (%o octal, %x lowercase hex,
1923 %X uppercase hex).
1924 %c means print as a single character.
1925 %f means print as a floating-point number in fixed notation (e.g. 785.200).
1926 %e or %E means print as a floating-point number in scientific notation
1927 (e.g. 7.85200e+03).
1928 %g or %G means print as a floating-point number in \"pretty format\";
1929 depending on the number, either %f or %e/%E format will be used, and
1930 trailing zeroes are removed from the fractional part.
1931 The argument used for all but %s and %S must be a number. It will be
1932 converted to an integer or a floating-point number as necessary.
1933
1934 %$ means reposition to read a specific numbered argument; for example,
1935 %3$s would apply the `%s' to the third argument after the control string,
1936 and the next format directive would use the fourth argument, the
1937 following one the fifth argument, etc. (There must be a positive integer
1938 between the % and the $).
1939 Zero or more of the flag characters `-', `+', ` ', `0', and `#' may be
1940 specified between the optional repositioning spec and the conversion
1941 character; see below.
1942 An optional minimum field width may be specified after any flag characters
1943 and before the conversion character; it specifies the minimum number of
1944 characters that the converted argument will take up. Padding will be
1945 added on the left (or on the right, if the `-' flag is specified), as
1946 necessary. Padding is done with spaces, or with zeroes if the `0' flag
1947 is specified.
1948 An optional period character and precision may be specified after any
1949 minimum field width. It specifies the minimum number of digits to
1950 appear in %d, %i, %o, %x, and %X conversions (the number is padded
1951 on the left with zeroes as necessary); the number of digits printed
1952 after the decimal point for %f, %e, and %E conversions; the number
1953 of significant digits printed in %g and %G conversions; and the
1954 maximum number of non-padding characters printed in %s and %S
1955 conversions. The default precision for floating-point conversions
1956 is six.
1957
1958 The ` ' and `+' flags mean prefix non-negative numbers with a space or
1959 plus sign, respectively.
1960 The `#' flag means print numbers in an alternate, more verbose format:
1961 octal numbers begin with zero; hex numbers begin with a 0x or 0X;
1962 a decimal point is printed in %f, %e, and %E conversions even if no
1963 numbers are printed after it; and trailing zeroes are not omitted in
1964 %g and %G conversions.
1965
1966 Use %% to put a single % into the output.
1967 */ )
1968 (nargs, args)
1969 int nargs;
1970 Lisp_Object *args;
1971 {
1972 /* It should not be necessary to GCPRO ARGS, because
1973 the caller in the interpreter should take care of that. */
1974
1975 CHECK_STRING (args[0]);
1976 return emacs_doprnt_string_lisp (0, args[0], 0, nargs - 1, args + 1);
1977 }
1978
1979
1980 DEFUN ("char-equal", Fchar_equal, Schar_equal, 2, 3, 0 /*
1981 Return t if two characters match, optionally ignoring case.
1982 Both arguments must be characters (i.e. integers).
1983 Case is ignored if `case-fold-search' is non-nil in BUFFER.
1984 If BUFFER is nil, the current buffer is assumed.
1985 */ )
1986 (c1, c2, buffer)
1987 Lisp_Object c1, c2, buffer;
1988 {
1989 Emchar x1, x2;
1990 struct buffer *buf = decode_buffer (buffer, 1);
1991
1992 CHECK_CHAR_COERCE_INT (c1);
1993 CHECK_CHAR_COERCE_INT (c2);
1994 x1 = XCHAR (c1);
1995 x2 = XCHAR (c2);
1996
1997 if (!NILP (buf->case_fold_search)
1998 ? DOWNCASE (buf, x1) == DOWNCASE (buf, x2)
1999 : x1 == x2)
2000 return Qt;
2001 return Qnil;
2002 }
2003
2004 #if 0 /* Undebugged FSFmacs code */
2005 /* Transpose the markers in two regions of the current buffer, and
2006 adjust the ones between them if necessary (i.e.: if the regions
2007 differ in size).
2008
2009 Traverses the entire marker list of the buffer to do so, adding an
2010 appropriate amount to some, subtracting from some, and leaving the
2011 rest untouched. Most of this is copied from adjust_markers in insdel.c.
2012
2013 It's the caller's job to see that (start1 <= end1 <= start2 <= end2). */
2014
2015 void
2016 transpose_markers (Bufpos start1, Bufpos end1, Bufpos start2, Bufpos end2)
2017 {
2018 Charcount amt1, amt2, diff;
2019 Bufpos mpos;
2020 Lisp_Object marker;
2021 struct buffer *buf = current_buffer;
2022
2023 /* Update point as if it were a marker. */
2024 if (BUF_PT (buf) < start1)
2025 ;
2026 else if (BUF_PT (buf) < end1)
2027 BUF_SET_PT (buf, BUF_PT (buf) + (end2 - end1));
2028 else if (BUF_PT (buf) < start2)
2029 BUF_SET_PT (buf, BUF_PT (buf) + (end2 - start2) - (end1 - start1));
2030 else if (BUF_PT (buf) < end2)
2031 BUF_SET_PT (buf, BUF_PT (buf) - (start2 - start1));
2032
2033 /* We used to adjust the endpoints here to account for the gap, but that
2034 isn't good enough. Even if we assume the caller has tried to move the
2035 gap out of our way, it might still be at start1 exactly, for example;
2036 and that places it `inside' the interval, for our purposes. The amount
2037 of adjustment is nontrivial if there's a `denormalized' marker whose
2038 position is between GPT and GPT + GAP_SIZE, so it's simpler to leave
2039 the dirty work to Fmarker_position, below. */
2040
2041 /* The difference between the region's lengths */
2042 diff = (end2 - start2) - (end1 - start1);
2043
2044 /* For shifting each marker in a region by the length of the other
2045 * region plus the distance between the regions.
2046 */
2047 amt1 = (end2 - start2) + (start2 - end1);
2048 amt2 = (end1 - start1) + (start2 - end1);
2049
2050 for (marker = BUF_MARKERS (buf); !NILP (marker);
2051 marker = XMARKER (marker)->chain)
2052 {
2053 mpos = marker_position (marker);
2054 if (mpos >= start1 && mpos < end2)
2055 {
2056 if (mpos < end1)
2057 mpos += amt1;
2058 else if (mpos < start2)
2059 mpos += diff;
2060 else
2061 mpos -= amt2;
2062 set_marker_position (marker, mpos);
2063 }
2064 }
2065 }
2066
2067 #endif
2068
2069 DEFUN ("transpose-regions", Ftranspose_regions, Stranspose_regions, 4, 5, 0 /*
2070 Transpose region START1 to END1 with START2 to END2.
2071 The regions may not be overlapping, because the size of the buffer is
2072 never changed in a transposition.
2073
2074 Optional fifth arg LEAVE_MARKERS, if non-nil, means don't transpose
2075 any markers that happen to be located in the regions. (#### BUG: currently
2076 this function always acts as if LEAVE_MARKERS is non-nil.)
2077
2078 Transposing beyond buffer boundaries is an error.
2079 */ )
2080 (startr1, endr1, startr2, endr2, leave_markers)
2081 Lisp_Object startr1, endr1, startr2, endr2, leave_markers;
2082 {
2083 Bufpos start1, end1, start2, end2;
2084 Charcount len1, len2;
2085 Lisp_Object string1, string2;
2086 struct buffer *buf = current_buffer;
2087
2088 get_buffer_range_char (buf, startr1, endr1, &start1, &end1, 0);
2089 get_buffer_range_char (buf, startr2, endr2, &start2, &end2, 0);
2090
2091 len1 = end1 - start1;
2092 len2 = end2 - start2;
2093
2094 if (start2 < end1)
2095 error ("transposed regions not properly ordered");
2096 else if (start1 == end1 || start2 == end2)
2097 error ("transposed region may not be of length 0");
2098
2099 string1 = make_string_from_buffer (buf, start1, len1);
2100 string2 = make_string_from_buffer (buf, start2, len2);
2101 buffer_delete_range (buf, start2, end2, 0);
2102 buffer_insert_lisp_string_1 (buf, start2, string1, 0);
2103 buffer_delete_range (buf, start1, end1, 0);
2104 buffer_insert_lisp_string_1 (buf, start1, string2, 0);
2105
2106 /* In FSFmacs there is a whole bunch of really ugly code here
2107 to attempt to transpose the regions without using up any
2108 extra memory. Although the intent may be good, the result
2109 was highly bogus. */
2110
2111 return Qnil;
2112 }
2113
2114
2115 /************************************************************************/
2116 /* initialization */
2117 /************************************************************************/
2118
2119 void
2120 syms_of_editfns (void)
2121 {
2122 defsymbol (&Qpoint, "point");
2123 defsymbol (&Qmark, "mark");
2124 defsymbol (&Qregion_beginning, "region-beginning");
2125 defsymbol (&Qregion_end, "region-end");
2126 defsymbol (&Qformat, "format");
2127
2128 defsubr (&Schar_equal);
2129 defsubr (&Sgoto_char);
2130 defsubr (&Sstring_to_char);
2131 defsubr (&Schar_to_string);
2132 defsubr (&Sbuffer_substring);
2133
2134 defsubr (&Spoint_marker);
2135 defsubr (&Smark_marker);
2136 defsubr (&Spoint);
2137 defsubr (&Sregion_beginning);
2138 defsubr (&Sregion_end);
2139 defsubr (&Ssave_excursion);
2140
2141 defsubr (&Sbufsize);
2142 defsubr (&Spoint_max);
2143 defsubr (&Spoint_min);
2144 defsubr (&Spoint_min_marker);
2145 defsubr (&Spoint_max_marker);
2146
2147 defsubr (&Sbobp);
2148 defsubr (&Seobp);
2149 defsubr (&Sbolp);
2150 defsubr (&Seolp);
2151 defsubr (&Sfollowing_char);
2152 defsubr (&Spreceding_char);
2153 defsubr (&Schar_after);
2154 defsubr (&Sinsert);
2155 defsubr (&Sinsert_string);
2156 defsubr (&Sinsert_before_markers);
2157 defsubr (&Sinsert_char);
2158
2159 defsubr (&Suser_login_name);
2160 defsubr (&Suser_real_login_name);
2161 defsubr (&Suser_uid);
2162 defsubr (&Suser_real_uid);
2163 defsubr (&Suser_full_name);
2164 defsubr (&Semacs_pid);
2165 defsubr (&Scurrent_time);
2166 defsubr (&Scurrent_process_time);
2167 defsubr (&Sformat_time_string);
2168 defsubr (&Sdecode_time);
2169 defsubr (&Sencode_time);
2170 defsubr (&Scurrent_time_string);
2171 defsubr (&Scurrent_time_zone);
2172 defsubr (&Sset_time_zone_rule);
2173 defsubr (&Ssystem_name);
2174 defsubr (&Sformat);
2175
2176 defsubr (&Sinsert_buffer_substring);
2177 defsubr (&Scompare_buffer_substrings);
2178 defsubr (&Ssubst_char_in_region);
2179 defsubr (&Stranslate_region);
2180 defsubr (&Sdelete_region);
2181 defsubr (&Swiden);
2182 defsubr (&Snarrow_to_region);
2183 defsubr (&Ssave_restriction);
2184 defsubr (&Stranspose_regions);
2185
2186 defsymbol (&Qzmacs_update_region, "zmacs-update-region");
2187 defsymbol (&Qzmacs_deactivate_region, "zmacs-deactivate-region");
2188 defsymbol (&Qzmacs_region_buffer, "zmacs-region-buffer");
2189 }
2190
2191 void
2192 vars_of_editfns (void)
2193 {
2194 staticpro (&Vsystem_name);
2195 #if 0
2196 staticpro (&Vuser_full_name);
2197 staticpro (&Vuser_name);
2198 staticpro (&Vuser_real_name);
2199 #endif
2200 DEFVAR_BOOL ("zmacs-regions", &zmacs_regions /*
2201 *Whether LISPM-style active regions should be used.
2202 This means that commands which operate on the region (the area between the
2203 point and the mark) will only work while the region is in the ``active''
2204 state, which is indicated by highlighting. Executing most commands causes
2205 the region to not be in the active state, so (for example) \\[kill-region] will only
2206 work immediately after activating the region.
2207
2208 More specifically:
2209
2210 - Commands which operate on the region only work if the region is active.
2211 - Only a very small set of commands cause the region to become active:
2212 Those commands whose semantics are to mark an area, like mark-defun.
2213 - The region is deactivated after each command that is executed, except that:
2214 - \"Motion\" commands do not change whether the region is active or not.
2215
2216 set-mark-command (C-SPC) pushes a mark and activates the region. Moving the
2217 cursor with normal motion commands (C-n, C-p, etc) will cause the region
2218 between point and the recently-pushed mark to be highlighted. It will
2219 remain highlighted until some non-motion comand is executed.
2220
2221 exchange-point-and-mark (\\[exchange-point-and-mark]) activates the region. So if you mark a
2222 region and execute a command that operates on it, you can reactivate the
2223 same region with \\[exchange-point-and-mark] (or perhaps \\[exchange-point-and-mark] \\[exchange-point-and-mark]) to operate on it
2224 again.
2225
2226 Generally, commands which push marks as a means of navigation (like
2227 beginning-of-buffer and end-of-buffer (M-< and M->)) do not activate the
2228 region. But commands which push marks as a means of marking an area of
2229 text (like mark-defun (\\[mark-defun]), mark-word (\\[mark-word]) or mark-whole-buffer (\\[mark-whole-buffer]))
2230 do activate the region.
2231
2232 The way the command loop actually works with regard to deactivating the
2233 region is as follows:
2234
2235 - If the variable `zmacs-region-stays' has been set to t during the command
2236 just executed, the region is left alone (this is how the motion commands
2237 make the region stay around; see the `_' flag in the `interactive'
2238 specification). `zmacs-region-stays' is reset to nil before each command
2239 is executed.
2240 - If the function `zmacs-activate-region' has been called during the command
2241 just executed, the region is left alone. Very few functions should
2242 actually call this function.
2243 - Otherwise, if the region is active, the region is deactivated and
2244 the `zmacs-deactivate-region-hook' is called.
2245 */ );
2246 /* Zmacs style active regions are now ON by default */
2247 zmacs_regions = 1;
2248
2249 DEFVAR_BOOL ("zmacs-region-active-p", &zmacs_region_active_p /*
2250 Do not alter this. It is for internal use only.
2251 */ );
2252 zmacs_region_active_p = 0;
2253
2254 DEFVAR_BOOL ("zmacs-region-stays", &zmacs_region_stays /*
2255 Commands which do not wish to affect whether the region is currently
2256 highlighted should set this to t. Normally, the region is turned off after
2257 executing each command that did not explicitly turn it on with the function
2258 zmacs-activate-region. Setting this to true lets a command be non-intrusive.
2259 See the variable `zmacs-regions'.
2260 */ );
2261 zmacs_region_stays = 0;
2262
2263 DEFVAR_BOOL ("atomic-extent-goto-char-p", &atomic_extent_goto_char_p /*
2264 Do not use this -- it will be going away soon.
2265 Indicates if `goto-char' has just been run. This information is allegedly
2266 needed to get the desired behavior for atomic extents and unfortunately
2267 is not available by any other means.
2268 */ );
2269 atomic_extent_goto_char_p = 0;
2270 }