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