Mercurial > hg > xemacs-beta

comparison src/minibuf.c @ 428:3ecd8885ac67 r21-2-22

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