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