Mercurial > hg > xemacs-beta

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 9ee227acff29
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 /* Minibuffer input and completion.
2 Copyright (C) 1985, 1986, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Synched up with: Mule 2.0, FSF 19.28. Mule-ized except as noted.
23 Substantially different from FSF. */
24
25 #include <config.h>
26 #include "lisp.h"
27
28 #include "buffer.h"
29 #include "commands.h"
30 #include "console-stream.h"
31 #include "events.h"
32 #include "frame.h"
33 #include "insdel.h"
34 #include "redisplay.h"
35 #include "window.h"
36
37 /* Depth in minibuffer invocations. */
38 int minibuf_level;
39
40 Lisp_Object Qcompletion_ignore_case;
41
42 /* Nonzero means completion ignores case. */
43 int completion_ignore_case;
44
45 /* List of regexps that should restrict possible completions. */
46 Lisp_Object Vcompletion_regexp_list;
47
48 /* The echo area buffer. */
49 Lisp_Object Vecho_area_buffer;
50
51 /* Prompt to display in front of the minibuffer contents */
52 Lisp_Object Vminibuf_prompt;
53
54 /* Hook to run just after entry to minibuffer. */
55 Lisp_Object Qminibuffer_setup_hook, Vminibuffer_setup_hook;
56
57 Lisp_Object Qappend_message, Qcurrent_message_label,
58 Qclear_message, Qdisplay_message;
59
60
61 DEFUN ("minibuffer-depth", Fminibuffer_depth, Sminibuffer_depth, 0, 0, 0 /*
62 Return current depth of activations of minibuffer, a nonnegative integer.
63 */ )
64 ()
65 {
66 return make_int (minibuf_level);
67 }
68
69 /* The default buffer to use as the window-buffer of minibuffer windows */
70 /* Note there is special code in kill-buffer to make this unkillable */
71 Lisp_Object Vminibuffer_zero;
72
73
74 /* Actual minibuffer invocation. */
75
76 static Lisp_Object
77 read_minibuffer_internal_unwind (Lisp_Object unwind_data)
78 {
79 Lisp_Object frame;
80 XWINDOW (minibuf_window)->last_modified[CURRENT_DISP] = Qzero;
81 XWINDOW (minibuf_window)->last_modified[DESIRED_DISP] = Qzero;
82 XWINDOW (minibuf_window)->last_modified[CMOTION_DISP] = Qzero;
83 XWINDOW (minibuf_window)->last_facechange[CURRENT_DISP] = Qzero;
84 XWINDOW (minibuf_window)->last_facechange[DESIRED_DISP] = Qzero;
85 XWINDOW (minibuf_window)->last_facechange[CMOTION_DISP] = Qzero;
86 Vminibuf_prompt = Felt (unwind_data, Qzero);
87 minibuf_level = XINT (Felt (unwind_data, make_int (1)));
88 while (CONSP (unwind_data))
89 {
90 Lisp_Object victim = unwind_data;
91 unwind_data = XCDR (unwind_data);
92 free_cons (XCONS (victim));
93 }
94
95 /* If cursor is on the minibuffer line,
96 show the user we have exited by putting it in column 0. */
97 frame = Fselected_frame (Qnil);
98 if (!noninteractive
99 && !NILP (frame)
100 && !NILP (XFRAME (frame)->minibuffer_window))
101 {
102 struct window *w = XWINDOW (XFRAME (frame)->minibuffer_window);
103 redisplay_move_cursor (w, 0, 0);
104 }
105
106 return Qnil;
107 }
108
109 DEFUN ("read-minibuffer-internal",
110 Fread_minibuffer_internal, Sread_minibuffer_internal,
111 1, 1, 0 /*
112 Lowest-level interface to minibuffers. Don't call this.
113 */ )
114 (prompt)
115 Lisp_Object prompt;
116 {
117 /* This function can GC */
118 int speccount = specpdl_depth ();
119 Lisp_Object val;
120
121 CHECK_STRING (prompt);
122
123 single_console_state ();
124
125 record_unwind_protect (read_minibuffer_internal_unwind,
126 noseeum_cons
127 (Vminibuf_prompt,
128 noseeum_cons (make_int (minibuf_level), Qnil)));
129 Vminibuf_prompt = LISP_GETTEXT (prompt);
130
131 /* NOTE: Here (or somewhere around here), in FSFmacs 19.30,
132 choose_minibuf_frame() is called. This is the only
133 place in FSFmacs that it's called any more -- there's
134 also a call in xterm.c, but commented out, and 19.28
135 had the calls in different places.
136
137 choose_minibuf_frame() does the following:
138
139 if (!EQ (minibuf_window, selected_frame()->minibuffer_window))
140 {
141 Fset_window_buffer (selected_frame()->minibuffer_window,
142 XWINDOW (minibuf_window)->buffer);
143 minibuf_window = selected_frame()->minibuffer_window;
144 }
145
146 #### Note that we don't do the set-window-buffer. This call is
147 similar, but not identical, to a set-window-buffer call made
148 in `read-from-minibuffer' in minibuf.el. I hope it's close
149 enough, because minibuf_window isn't really exported to Lisp.
150
151 The comment above choose_minibuf_frame() reads:
152
153 Put minibuf on currently selected frame's minibuffer.
154 We do this whenever the user starts a new minibuffer
155 or when a minibuffer exits. */
156
157 minibuf_window = FRAME_MINIBUF_WINDOW (selected_frame ());
158
159 run_hook (Qminibuffer_setup_hook);
160
161 minibuf_level++;
162 clear_echo_area (selected_frame (), Qnil, 0);
163
164 val = call_command_loop (Qt);
165
166 return (unbind_to (speccount, val));
167 }
168
169
170
171 /* Completion hair */
172
173 /* Compare exactly LEN chars of strings at S1 and S2,
174 ignoring case if appropriate.
175 Return -1 if strings match,
176 else number of chars that match at the beginning. */
177
178 /* Note that this function works in Charcounts, unlike most functions.
179 This is necessary for many reasons, one of which is that two
180 strings may match even if they have different numbers of bytes,
181 if IGNORE_CASE is true. */
182
183 Charcount
184 scmp_1 (CONST Bufbyte *s1, CONST Bufbyte *s2, Charcount len,
185 int ignore_case)
186 {
187 Charcount l = len;
188
189 if (ignore_case)
190 {
191 while (l)
192 {
193 Bufbyte c1 = DOWNCASE (current_buffer, charptr_emchar (s1));
194 Bufbyte c2 = DOWNCASE (current_buffer, charptr_emchar (s2));
195
196 if (c1 == c2)
197 {
198 l--;
199 INC_CHARPTR (s1);
200 INC_CHARPTR (s2);
201 }
202 else
203 break;
204 }
205 }
206 else
207 {
208 while (l && charptr_emchar (s1) == charptr_emchar (s2))
209 {
210 l--;
211 INC_CHARPTR (s1);
212 INC_CHARPTR (s2);
213 }
214 }
215
216 if (l == 0)
217 return -1;
218 else return len - l;
219 }
220
221
222 int
223 regexp_ignore_completion_p (CONST Bufbyte *nonreloc,
224 Lisp_Object reloc, Bytecount offset,
225 Bytecount length)
226 {
227 /* Ignore this element if it fails to match all the regexps. */
228 if (!NILP (Vcompletion_regexp_list))
229 {
230 Lisp_Object regexps;
231 for (regexps = Vcompletion_regexp_list;
232 CONSP (regexps);
233 regexps = XCDR (regexps))
234 {
235 Lisp_Object re = XCAR (regexps);
236 if (STRINGP (re)
237 && (fast_string_match (re, nonreloc, reloc, offset,
238 length, 0, ERROR_ME, 0) >= 0))
239 return (1);
240 }
241 }
242 return (0);
243 }
244
245
246 /* Callers should GCPRO, since this may call eval */
247 static int
248 ignore_completion_p (Lisp_Object completion_string,
249 Lisp_Object pred, Lisp_Object completion)
250 {
251 if (regexp_ignore_completion_p (0, completion_string, 0, -1))
252 return (1);
253
254 /* Ignore this element if there is a predicate
255 and the predicate doesn't like it. */
256 if (!NILP (pred))
257 {
258 Lisp_Object tem;
259 if (EQ (pred, Qcommandp))
260 tem = Fcommandp (completion);
261 else
262 tem = call1 (pred, completion);
263 if (NILP (tem))
264 return (1);
265 }
266 return (0);
267 }
268
269
270
271
272 DEFUN ("try-completion", Ftry_completion, Stry_completion, 2, 3, 0 /*
273 Return common substring of all completions of STRING in ALIST.
274 Each car of each element of ALIST is tested to see if it begins with STRING.
275 All that match are compared together; the longest initial sequence
276 common to all matches is returned as a string.
277 If there is no match at all, nil is returned.
278 For an exact match, t is returned.
279
280 ALIST can be an obarray instead of an alist.
281 Then the print names of all symbols in the obarray are the possible matches.
282
283 ALIST can also be a function to do the completion itself.
284 It receives three arguments: the values STRING, PREDICATE and nil.
285 Whatever it returns becomes the value of `try-completion'.
286
287 If optional third argument PREDICATE is non-nil,
288 it is used to test each possible match.
289 The match is a candidate only if PREDICATE returns non-nil.
290 The argument given to PREDICATE is the alist element or the symbol from the obarray.
291 */ )
292 (string, alist, pred)
293 Lisp_Object string, alist, pred;
294 {
295 /* This function can GC */
296 Lisp_Object bestmatch, tail;
297 Charcount bestmatchsize = 0;
298 int list;
299 int indice = 0;
300 int obsize = 0;
301 int matchcount = 0;
302 Lisp_Object bucket;
303 Charcount slength, blength;
304
305 CHECK_STRING (string);
306
307 if (CONSP (alist))
308 {
309 Lisp_Object tem = XCAR (alist);
310 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
311 return call3 (alist, string, pred, Qnil);
312 else
313 list = 1;
314 }
315 else if (VECTORP (alist))
316 list = 0;
317 else if (NILP (alist))
318 list = 1;
319 else
320 return call3 (alist, string, pred, Qnil);
321
322 bestmatch = Qnil;
323 blength = 0;
324 slength = string_char_length (XSTRING (string));
325
326 /* If ALIST is not a list, set TAIL just for gc pro. */
327 tail = alist;
328 if (!list)
329 {
330 obsize = vector_length (XVECTOR (alist));
331 bucket = vector_data (XVECTOR (alist))[indice];
332 }
333
334 while (1)
335 {
336 /* Get the next element of the alist or obarray. */
337 /* Exit the loop if the elements are all used up. */
338 /* elt gets the alist element or symbol.
339 eltstring gets the name to check as a completion. */
340 Lisp_Object elt;
341 Lisp_Object eltstring;
342
343 if (list)
344 {
345 if (NILP (tail))
346 break;
347 elt = Fcar (tail);
348 eltstring = Fcar (elt);
349 tail = Fcdr (tail);
350 }
351 else
352 {
353 if (!ZEROP (bucket))
354 {
355 struct Lisp_Symbol *next = symbol_next (XSYMBOL (bucket));
356 elt = bucket;
357 eltstring = Fsymbol_name (elt);
358 if (next)
359 XSETSYMBOL (bucket, next);
360 else
361 bucket = Qzero;
362 }
363 else if (++indice >= obsize)
364 break;
365 else
366 {
367 bucket = vector_data (XVECTOR (alist))[indice];
368 continue;
369 }
370 }
371
372 /* Is this element a possible completion? */
373
374 if (STRINGP (eltstring))
375 {
376 Charcount eltlength = string_char_length (XSTRING (eltstring));
377 if (slength <= eltlength
378 && (0 > scmp (string_data (XSTRING (eltstring)),
379 string_data (XSTRING (string)),
380 slength)))
381 {
382 {
383 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
384 int loser;
385 GCPRO4 (tail, string, eltstring, bestmatch);
386 loser = ignore_completion_p (eltstring, pred, elt);
387 UNGCPRO;
388 if (loser) /* reject this one */
389 continue;
390 }
391
392 /* Update computation of how much all possible
393 completions match */
394
395 matchcount++;
396 if (NILP (bestmatch))
397 {
398 bestmatch = eltstring;
399 blength = eltlength;
400 bestmatchsize = eltlength;
401 }
402 else
403 {
404 Charcount compare = min (bestmatchsize, eltlength);
405 Charcount matchsize =
406 scmp (string_data (XSTRING (bestmatch)),
407 string_data (XSTRING (eltstring)),
408 compare);
409 if (matchsize < 0)
410 matchsize = compare;
411 if (completion_ignore_case)
412 {
413 /* If this is an exact match except for case,
414 use it as the best match rather than one that is not
415 an exact match. This way, we get the case pattern
416 of the actual match. */
417 if ((matchsize == eltlength
418 && matchsize < blength)
419 ||
420 /* If there is more than one exact match ignoring
421 case, and one of them is exact including case,
422 prefer that one. */
423 /* If there is no exact match ignoring case,
424 prefer a match that does not change the case
425 of the input. */
426 ((matchsize == eltlength)
427 ==
428 (matchsize == blength)
429 && 0 > scmp_1 (string_data (XSTRING (eltstring)),
430 string_data (XSTRING (string)),
431 slength, 0)
432 && 0 <= scmp_1 (string_data (XSTRING (bestmatch)),
433 string_data (XSTRING (string)),
434 slength, 0)))
435 {
436 bestmatch = eltstring;
437 blength = eltlength;
438 }
439 }
440 bestmatchsize = matchsize;
441 }
442 }
443 }
444 }
445
446 if (NILP (bestmatch))
447 return Qnil; /* No completions found */
448 /* If we are ignoring case, and there is no exact match,
449 and no additional text was supplied,
450 don't change the case of what the user typed. */
451 if (completion_ignore_case
452 && bestmatchsize == slength
453 && blength > bestmatchsize)
454 return string;
455
456 /* Return t if the supplied string is an exact match (counting case);
457 it does not require any change to be made. */
458 if (matchcount == 1
459 && bestmatchsize == slength
460 && 0 > scmp_1 (string_data (XSTRING (bestmatch)),
461 string_data (XSTRING (string)),
462 bestmatchsize, 0))
463 return Qt;
464
465 /* Else extract the part in which all completions agree */
466 return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize));
467 }
468
469
470 DEFUN ("all-completions", Fall_completions, Sall_completions, 2, 3, 0 /*
471 Search for partial matches to STRING in ALIST.
472 Each car of each element of ALIST is tested to see if it begins with STRING.
473 The value is a list of all the strings from ALIST that match.
474 ALIST can be an obarray instead of an alist.
475 Then the print names of all symbols in the obarray are the possible matches.
476
477 ALIST can also be a function to do the completion itself.
478 It receives three arguments: the values STRING, PREDICATE and t.
479 Whatever it returns becomes the value of `all-completions'.
480
481 If optional third argument PREDICATE is non-nil,
482 it is used to test each possible match.
483 The match is a candidate only if PREDICATE returns non-nil.
484 The argument given to PREDICATE is the alist element or
485 the symbol from the obarray.
486 */ )
487 (string, alist, pred)
488 Lisp_Object string, alist, pred;
489 {
490 /* This function can GC */
491 Lisp_Object tail;
492 Lisp_Object allmatches;
493 int list;
494 int indice = 0;
495 int obsize = 0;
496 Lisp_Object bucket;
497 Charcount slength;
498
499 CHECK_STRING (string);
500
501 if (CONSP (alist))
502 {
503 Lisp_Object tem = XCAR (alist);
504 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
505 return call3 (alist, string, pred, Qt);
506 else
507 list = 1;
508 }
509 else if (VECTORP (alist))
510 list = 0;
511 else if (NILP (alist))
512 list = 1;
513 else
514 return call3 (alist, string, pred, Qt);
515
516 allmatches = Qnil;
517 slength = string_char_length (XSTRING (string));
518
519 /* If ALIST is not a list, set TAIL just for gc pro. */
520 tail = alist;
521 if (!list)
522 {
523 obsize = vector_length (XVECTOR (alist));
524 bucket = vector_data (XVECTOR (alist))[indice];
525 }
526
527 while (1)
528 {
529 /* Get the next element of the alist or obarray. */
530 /* Exit the loop if the elements are all used up. */
531 /* elt gets the alist element or symbol.
532 eltstring gets the name to check as a completion. */
533 Lisp_Object elt;
534 Lisp_Object eltstring;
535
536 if (list)
537 {
538 if (NILP (tail))
539 break;
540 elt = Fcar (tail);
541 eltstring = Fcar (elt);
542 tail = Fcdr (tail);
543 }
544 else
545 {
546 if (!ZEROP (bucket))
547 {
548 struct Lisp_Symbol *next = symbol_next (XSYMBOL (bucket));
549 elt = bucket;
550 eltstring = Fsymbol_name (elt);
551 if (next)
552 XSETSYMBOL (bucket, next);
553 else
554 bucket = Qzero;
555 }
556 else if (++indice >= obsize)
557 break;
558 else
559 {
560 bucket = vector_data (XVECTOR (alist))[indice];
561 continue;
562 }
563 }
564
565 /* Is this element a possible completion? */
566
567 if (STRINGP (eltstring)
568 && (slength <= string_char_length (XSTRING (eltstring)))
569 /* Reject alternatives that start with space
570 unless the input starts with space. */
571 && ((string_char_length (XSTRING (string)) > 0 &&
572 string_char (XSTRING (string), 0) == ' ')
573 || string_char (XSTRING (eltstring), 0) != ' ')
574 && (0 > scmp (string_data (XSTRING (eltstring)),
575 string_data (XSTRING (string)),
576 slength)))
577 {
578 /* Yes. Now check whether predicate likes it. */
579 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
580 int loser;
581 GCPRO4 (tail, eltstring, allmatches, string);
582 loser = ignore_completion_p (eltstring, pred, elt);
583 UNGCPRO;
584 if (!loser)
585 /* Ok => put it on the list. */
586 allmatches = Fcons (eltstring, allmatches);
587 }
588 }
589
590 return Fnreverse (allmatches);
591 }
592
593 /* Useless FSFmacs functions */
594 /* More than useless. I've nuked minibuf_prompt_width so they won't
595 function at all in XEmacs at the moment. They are used to
596 implement some braindamage in FSF which we aren't including. --cet */
597
598 #if 0
599 xxDEFUN ("minibuffer-prompt", Fminibuffer_prompt, Sminibuffer_prompt, 0, 0, 0,
600 "Return the prompt string of the currently-active minibuffer.\n"
601 "If no minibuffer is active, return nil.")
602 ()
603 {
604 return (Fcopy_sequence (Vminibuf_prompt));
605 }
606
607 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width,
608 Sminibuffer_prompt_width, 0, 0, 0,
609 "Return the display width of the minibuffer prompt.")
610 ()
611 {
612 return (make_int (minibuf_prompt_width));
613 }
614 #endif
615
616
617 /************************************************************************/
618 /* echo area */
619 /************************************************************************/
620
621 extern int stdout_needs_newline;
622
623 static Lisp_Object
624 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
625 int no_restore)
626 {
627 if (!NILP (Ffboundp (Qclear_message)))
628 {
629 Lisp_Object frame;
630
631 XSETFRAME (frame, f);
632 return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
633 no_restore ? Qt : Qnil);
634 }
635 else
636 {
637 write_string_to_stdio_stream (stderr, 0, (CONST Bufbyte *) "\n", 0, 1,
638 FORMAT_DISPLAY);
639 return Qnil;
640 }
641 }
642
643 Lisp_Object
644 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
645 {
646 return clear_echo_area_internal (f, label, 0, no_restore);
647 }
648
649 Lisp_Object
650 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
651 {
652 return clear_echo_area_internal (f, label, 1, no_restore);
653 }
654
655 void
656 echo_area_append (struct frame *f, CONST Bufbyte *nonreloc, Lisp_Object reloc,
657 Bytecount offset, Bytecount length,
658 Lisp_Object label)
659 {
660 Lisp_Object obj;
661 struct gcpro gcpro1;
662 Lisp_Object frame;
663
664 /* some callers pass in a null string as a way of clearing the echo area.
665 check for length == 0 now; if this case, neither nonreloc nor reloc
666 may be valid. */
667 if (length == 0)
668 return;
669
670 fixup_internal_substring (nonreloc, reloc, offset, &length);
671
672 /* also check it here, in case the string was really blank. */
673 if (length == 0)
674 return;
675
676 if (!NILP (Ffboundp (Qappend_message)))
677 {
678 if (STRINGP (reloc) && offset == 0 &&
679 length == string_length (XSTRING (reloc)))
680 obj = reloc;
681 else
682 {
683 if (STRINGP (reloc))
684 nonreloc = string_data (XSTRING (reloc));
685 obj = make_string (nonreloc + offset, length);
686 }
687
688 XSETFRAME (frame, f);
689 GCPRO1 (obj);
690 call4 (Qappend_message, label, obj, frame,
691 EQ (label, Qprint) ? Qt : Qnil);
692 UNGCPRO;
693 }
694 else
695 {
696 if (STRINGP (reloc))
697 nonreloc = string_data (XSTRING (reloc));
698 write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
699 FORMAT_DISPLAY);
700 }
701 }
702
703 void
704 echo_area_message (struct frame *f, CONST Bufbyte *nonreloc,
705 Lisp_Object reloc, Bytecount offset, Bytecount length,
706 Lisp_Object label)
707 {
708 clear_echo_area (f, label, 1);
709 echo_area_append (f, nonreloc, reloc, offset, length, label);
710 }
711
712 int
713 echo_area_active (struct frame *f)
714 {
715 /* By definition, the echo area is active if the echo-area buffer
716 is not empty. No need to call Lisp code. (Anyway, this function
717 is called from redisplay.) */
718 return (BUF_BEGV (XBUFFER (Vecho_area_buffer)) !=
719 BUF_ZV (XBUFFER (Vecho_area_buffer)));
720 }
721
722 Lisp_Object
723 echo_area_status (struct frame *f)
724 {
725 if (!NILP (Ffboundp (Qcurrent_message_label)))
726 {
727 Lisp_Object frame;
728
729 XSETFRAME (frame, f);
730 return (call1 (Qcurrent_message_label, frame));
731 }
732 else
733 return stdout_needs_newline ? Qmessage : Qnil;
734 }
735
736 Lisp_Object
737 echo_area_contents (struct frame *f)
738 {
739 /* See above. By definition, the contents of the echo-area buffer
740 are the contents of the echo area. */
741 return Fbuffer_substring (Qnil, Qnil, Vecho_area_buffer);
742 }
743
744 /* Dump an informative message to the echo area. This function takes a
745 string in internal format. */
746 void
747 message_internal (CONST Bufbyte *nonreloc, Lisp_Object reloc,
748 Bytecount offset, Bytecount length)
749 {
750 /* This can GC! */
751 if (NILP (Vexecuting_macro))
752 echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
753 Qmessage);
754 }
755
756 void
757 message_append_internal (CONST Bufbyte *nonreloc, Lisp_Object reloc,
758 Bytecount offset, Bytecount length)
759 {
760 /* This can GC! */
761 if (NILP (Vexecuting_macro))
762 echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
763 Qmessage);
764 }
765
766 /* The next three functions are interfaces to message_internal() that
767 take strings in external format. message() does I18N3 translating
768 on the format string; message_no_translate() does not. */
769
770 static void
771 message_1 (CONST char *fmt, va_list args)
772 {
773 if (fmt)
774 {
775 struct gcpro gcpro1;
776 /* message_internal() might GC, e.g. if there are after-change-hooks
777 on the echo area buffer */
778 Lisp_Object obj = emacs_doprnt_string_va ((CONST Bufbyte *) fmt, Qnil,
779 -1, args);
780 GCPRO1 (obj);
781 message_internal (0, obj, 0, -1);
782 UNGCPRO;
783 }
784 else
785 message_internal (0, Qnil, 0, 0);
786 }
787
788 static void
789 message_append_1 (CONST char *fmt, va_list args)
790 {
791 if (fmt)
792 {
793 struct gcpro gcpro1;
794 /* message_internal() might GC, e.g. if there are after-change-hooks
795 on the echo area buffer */
796 Lisp_Object obj = emacs_doprnt_string_va ((CONST Bufbyte *) fmt, Qnil,
797 -1, args);
798 GCPRO1 (obj);
799 message_append_internal (0, obj, 0, -1);
800 UNGCPRO;
801 }
802 else
803 message_append_internal (0, Qnil, 0, 0);
804 }
805
806 void
807 clear_message (void)
808 {
809 message_internal (0, Qnil, 0, 0);
810 }
811
812 void
813 message (CONST char *fmt, ...)
814 {
815 /* I think it's OK to pass the data of Lisp strings as arguments to
816 this function. No GC'ing will occur until the data has already
817 been copied. */
818 va_list args;
819
820 va_start (args, fmt);
821 if (fmt)
822 fmt = GETTEXT (fmt);
823 message_1 (fmt, args);
824 va_end (args);
825 }
826
827 void
828 message_append (CONST char *fmt, ...)
829 {
830 va_list args;
831
832 va_start (args, fmt);
833 if (fmt)
834 fmt = GETTEXT (fmt);
835 message_append_1 (fmt, args);
836 va_end (args);
837 }
838
839 void
840 message_no_translate (CONST char *fmt, ...)
841 {
842 /* I think it's OK to pass the data of Lisp strings as arguments to
843 this function. No GC'ing will occur until the data has already
844 been copied. */
845 va_list args;
846
847 va_start (args, fmt);
848 message_1 (fmt, args);
849 va_end (args);
850 }
851
852
853 /************************************************************************/
854 /* initialization */
855 /************************************************************************/
856
857 void
858 syms_of_minibuf (void)
859 {
860 defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
861
862 defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
863
864 defsubr (&Sminibuffer_depth);
865 #if 0
866 defsubr (&Sminibuffer_prompt);
867 defsubr (&Sminibuffer_prompt_width);
868 #endif
869
870 defsubr (&Sread_minibuffer_internal);
871
872 defsubr (&Stry_completion);
873 defsubr (&Sall_completions);
874
875 defsymbol (&Qappend_message, "append-message");
876 defsymbol (&Qclear_message, "clear-message");
877 defsymbol (&Qdisplay_message, "display-message");
878 defsymbol (&Qcurrent_message_label, "current-message-label");
879 }
880
881 void
882 vars_of_minibuf (void)
883 {
884 minibuf_level = 0;
885
886 staticpro (&Vminibuf_prompt);
887 Vminibuf_prompt = Qnil;
888
889 DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
890 Normal hook run just after entry to minibuffer.
891 */ );
892 Vminibuffer_setup_hook = Qnil;
893
894 DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
895 Non-nil means don't consider case significant in completion.
896 */ );
897 completion_ignore_case = 0;
898
899 /* Worthless doc string */
900 DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
901 List of regexps that should restrict possible completions.
902 */ );
903 Vcompletion_regexp_list = Qnil;
904 }
905
906 void
907 complex_vars_of_minibuf (void)
908 {
909 /* This function can GC */
910 #ifdef I18N3
911 /* #### This needs to be fixed up so that the gettext() gets called
912 at runtime instead of at load time. */
913 #endif
914 Vminibuffer_zero
915 = Fget_buffer_create
916 (Fpurecopy (build_string (DEFER_GETTEXT (" *Minibuf-0*"))));
917 Vecho_area_buffer
918 = Fget_buffer_create
919 (Fpurecopy (build_string (DEFER_GETTEXT (" *Echo Area*"))));
920 }