1 /* Minibuffer input and completion.
2 Copyright (C) 1985, 1986, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1995 Sun Microsystems, Inc.
5 This file is part of SXEmacs
7 SXEmacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 SXEmacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
21 /* Synched up with: Mule 2.0, FSF 19.28. Mule-ized except as noted.
22 Substantially different from FSF. */
24 /* #### dmoore - All sorts of things in here can call lisp, like message.
25 Track all this stuff. */
32 #include "console-stream.h"
33 #include "events/events.h"
36 #include "redisplay.h"
39 /* Depth in minibuffer invocations. */
42 Lisp_Object Qcompletion_ignore_case;
44 /* Nonzero means completion ignores case. */
45 int completion_ignore_case;
47 /* List of regexps that should restrict possible completions. */
48 Lisp_Object Vcompletion_regexp_list;
50 /* The echo area buffer. */
51 Lisp_Object Vecho_area_buffer;
53 /* Prompt to display in front of the minibuffer contents */
54 Lisp_Object Vminibuf_prompt;
56 /* Added on 97/3/14 by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
57 /* String to be displayed in front of prompt of the minibuffer contents */
58 Lisp_Object Vminibuf_preprompt;
60 /* Hook to run just after entry to minibuffer. */
61 Lisp_Object Qminibuffer_setup_hook, Vminibuffer_setup_hook;
63 Lisp_Object Qappend_message, Qcurrent_message_label,
64 Qclear_message, Qdisplay_message;
66 DEFUN("minibuffer-depth", Fminibuffer_depth, 0, 0, 0, /*
67 Return current depth of activations of minibuffer, a nonnegative integer.
71 return make_int(minibuf_level);
74 /* The default buffer to use as the window-buffer of minibuffer windows */
75 /* Note there is special code in kill-buffer to make this unkillable */
76 Lisp_Object Vminibuffer_zero;
78 /* Actual minibuffer invocation. */
80 static Lisp_Object read_minibuffer_internal_unwind(Lisp_Object unwind_data)
83 XWINDOW(minibuf_window)->last_modified[CURRENT_DISP] = Qzero;
84 XWINDOW(minibuf_window)->last_modified[DESIRED_DISP] = Qzero;
85 XWINDOW(minibuf_window)->last_modified[CMOTION_DISP] = Qzero;
86 XWINDOW(minibuf_window)->last_facechange[CURRENT_DISP] = Qzero;
87 XWINDOW(minibuf_window)->last_facechange[DESIRED_DISP] = Qzero;
88 XWINDOW(minibuf_window)->last_facechange[CMOTION_DISP] = Qzero;
89 Vminibuf_prompt = Felt(unwind_data, Qzero);
90 minibuf_level = XINT(Felt(unwind_data, make_int(1)));
91 while (CONSP(unwind_data)) {
92 Lisp_Object victim = unwind_data;
93 unwind_data = XCDR(unwind_data);
94 free_cons(XCONS(victim));
97 /* If cursor is on the minibuffer line,
98 show the user we have exited by putting it in column 0. */
99 frame = Fselected_frame(Qnil);
100 if (!noninteractive && !NILP(frame)
101 && !NILP(XFRAME(frame)->minibuffer_window)) {
102 struct window *w = XWINDOW(XFRAME(frame)->minibuffer_window);
103 redisplay_move_cursor(w, 0, 0);
109 /* 97/4/13 jhod: Added for input methods */
110 DEFUN("set-minibuffer-preprompt", Fset_minibuffer_preprompt, 1, 1, 0, /*
111 Set the minibuffer preprompt string to PREPROMPT. This is used by language
112 input methods to relay state information to the user.
116 if (NILP(preprompt)) {
117 Vminibuf_preprompt = Qnil;
119 CHECK_STRING(preprompt);
121 Vminibuf_preprompt = LISP_GETTEXT(preprompt);
126 DEFUN("read-minibuffer-internal", Fread_minibuffer_internal, 1, 1, 0, /*
127 Lowest-level interface to minibuffers. Don't call this.
131 /* This function can GC */
132 int speccount = specpdl_depth();
135 CHECK_STRING(prompt);
137 single_console_state();
139 record_unwind_protect(read_minibuffer_internal_unwind,
142 noseeum_cons(make_int(minibuf_level), Qnil)));
143 Vminibuf_prompt = LISP_GETTEXT(prompt);
145 /* NOTE: Here (or somewhere around here), in FSFmacs 19.30,
146 choose_minibuf_frame() is called. This is the only
147 place in FSFmacs that it's called any more -- there's
148 also a call in xterm.c, but commented out, and 19.28
149 had the calls in different places.
151 choose_minibuf_frame() does the following:
153 if (!EQ (minibuf_window, selected_frame()->minibuffer_window))
155 Fset_window_buffer (selected_frame()->minibuffer_window,
156 XWINDOW (minibuf_window)->buffer);
157 minibuf_window = selected_frame()->minibuffer_window;
160 #### Note that we don't do the set-window-buffer. This call is
161 similar, but not identical, to a set-window-buffer call made
162 in `read-from-minibuffer' in minibuf.el. I hope it's close
163 enough, because minibuf_window isn't really exported to Lisp.
165 The comment above choose_minibuf_frame() reads:
167 Put minibuf on currently selected frame's minibuffer.
168 We do this whenever the user starts a new minibuffer
169 or when a minibuffer exits. */
171 minibuf_window = FRAME_MINIBUF_WINDOW(selected_frame());
173 run_hook(Qminibuffer_setup_hook);
176 clear_echo_area(selected_frame(), Qnil, 0);
178 val = call_command_loop(Qt);
180 return unbind_to(speccount, val);
183 /* Completion hair */
185 /* Compare exactly LEN chars of strings at S1 and S2,
186 ignoring case if appropriate.
187 Return -1 if strings match,
188 else number of chars that match at the beginning. */
190 /* Note that this function works in Charcounts, unlike most functions.
191 This is necessary for many reasons, one of which is that two
192 strings may match even if they have different numbers of bytes,
193 if IGNORE_CASE is true. */
196 scmp_1(const Bufbyte * s1, const Bufbyte * s2, Charcount len, int ignore_case)
203 DOWNCASE(current_buffer, charptr_emchar(s1));
205 DOWNCASE(current_buffer, charptr_emchar(s2));
215 while (l && charptr_emchar(s1) == charptr_emchar(s2)) {
229 regexp_ignore_completion_p(const Bufbyte * nonreloc,
230 Lisp_Object reloc, Bytecount offset,
233 /* Ignore this element if it fails to match all the regexps. */
234 if (!NILP(Vcompletion_regexp_list)) {
236 EXTERNAL_LIST_LOOP(regexps, Vcompletion_regexp_list) {
237 Lisp_Object re = XCAR(regexps);
239 if (fast_string_match(re, nonreloc, reloc, offset,
240 length, 0, ERROR_ME, 0) < 0)
247 /* Callers should GCPRO, since this may call eval */
249 ignore_completion_p(Lisp_Object completion_string,
250 Lisp_Object pred, Lisp_Object completion)
252 if (regexp_ignore_completion_p(0, completion_string, 0, -1))
255 /* Ignore this element if there is a predicate
256 and the predicate doesn't like it. */
259 if (EQ(pred, Qcommandp))
260 tem = Fcommandp(completion);
262 tem = call1(pred, completion);
269 /* #### Maybe we should allow COLLECTION to be a hash table.
270 It is wrong for the use of obarrays to be better-rewarded than the
271 use of hash tables. By better-rewarded I mean that you can pass an
272 obarray to all of the completion functions, whereas you can't do
273 anything like that with a hash table.
275 To do so, there should probably be a
276 map_obarray_or_alist_or_hash_table function which would be used by
277 both Ftry_completion and Fall_completions. But would the
278 additional funcalls slow things down? */
280 DEFUN("try-completion", Ftry_completion, 2, 3, 0, /*
281 Return common substring of all completions of STRING in COLLECTION.
282 COLLECTION must be an alist, an obarray, or a function.
283 Each string in COLLECTION is tested to see if it begins with STRING.
284 All that match are compared together; the longest initial sequence
285 common to all matches is returned as a string. If there is no match
286 at all, nil is returned. For an exact match, t is returned.
288 If COLLECTION is an alist, the cars of the elements of the alist
289 \(which must be strings) form the set of possible completions.
291 If COLLECTION is an obarray, the names of all symbols in the obarray
292 are the possible completions.
294 If COLLECTION is a function, it is called with three arguments: the
295 values STRING, PREDICATE and nil. Whatever it returns becomes the
296 value of `try-completion'.
298 If optional third argument PREDICATE is non-nil, it is used to test
299 each possible match. The match is a candidate only if PREDICATE
300 returns non-nil. The argument given to PREDICATE is the alist element
301 or the symbol from the obarray.
303 (string, collection, predicate))
305 /* This function can GC */
306 Lisp_Object bestmatch, tail;
307 Charcount bestmatchsize = 0;
313 Charcount slength, blength;
315 CHECK_STRING(string);
317 if (CONSP(collection)) {
318 Lisp_Object tem = XCAR(collection);
319 if (SYMBOLP(tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
320 return call3(collection, string, predicate, Qnil);
323 } else if (VECTORP(collection))
325 else if (NILP(collection))
328 return call3(collection, string, predicate, Qnil);
332 slength = XSTRING_CHAR_LENGTH(string);
334 /* If COLLECTION is not a list, set TAIL just for gc pro. */
337 obsize = XVECTOR_LENGTH(collection);
338 bucket = XVECTOR_DATA(collection)[indice];
339 } else { /* warning suppression */
346 /* Get the next element of the alist or obarray. */
347 /* Exit the loop if the elements are all used up. */
348 /* elt gets the alist element or symbol.
349 eltstring gets the name to check as a completion. */
351 Lisp_Object eltstring;
357 eltstring = Fcar(elt);
360 if (!ZEROP(bucket)) {
362 if (!SYMBOLP(bucket)) {
364 ("Bad obarray passed to try-completions",
367 next = symbol_next(XSYMBOL(bucket));
369 eltstring = Fsymbol_name(elt);
371 XSETSYMBOL(bucket, next);
374 } else if (++indice >= obsize)
377 bucket = XVECTOR_DATA(collection)[indice];
382 /* Is this element a possible completion? */
384 if (STRINGP(eltstring)) {
385 Charcount eltlength = XSTRING_CHAR_LENGTH(eltstring);
386 if (slength <= eltlength
387 && (0 > scmp(XSTRING_DATA(eltstring),
388 XSTRING_DATA(string), slength))) {
390 struct gcpro gcpro1, gcpro2, gcpro3,
393 GCPRO4(tail, string, eltstring,
396 ignore_completion_p(eltstring,
399 if (loser) /* reject this one */
403 /* Update computation of how much all possible
407 if (NILP(bestmatch)) {
408 bestmatch = eltstring;
410 bestmatchsize = eltlength;
413 min(bestmatchsize, eltlength);
414 Charcount matchsize =
415 scmp(XSTRING_DATA(bestmatch),
416 XSTRING_DATA(eltstring),
420 if (completion_ignore_case) {
421 /* If this is an exact match except for case,
422 use it as the best match rather than one that is not
423 an exact match. This way, we get the case pattern
424 of the actual match. */
425 if ((matchsize == eltlength
426 && matchsize < blength)
428 /* If there is more than one exact match ignoring
429 case, and one of them is exact including case,
431 /* If there is no exact match ignoring case,
432 prefer a match that does not change the case
434 ((matchsize == eltlength)
435 == (matchsize == blength)
448 bestmatch = eltstring;
452 bestmatchsize = matchsize;
459 return Qnil; /* No completions found */
460 /* If we are ignoring case, and there is no exact match,
461 and no additional text was supplied,
462 don't change the case of what the user typed. */
463 if (completion_ignore_case
464 && bestmatchsize == slength && blength > bestmatchsize)
467 /* Return t if the supplied string is an exact match (counting case);
468 it does not require any change to be made. */
470 && bestmatchsize == slength
471 && 0 > scmp_1(XSTRING_DATA(bestmatch),
472 XSTRING_DATA(string), bestmatchsize, 0))
475 /* Else extract the part in which all completions agree */
476 return Fsubstring(bestmatch, Qzero, make_int(bestmatchsize));
479 DEFUN("all-completions", Fall_completions, 2, 3, 0, /*
480 Search for partial matches to STRING in COLLECTION.
481 COLLECTION must be an alist, an obarray, or a function.
482 Each string in COLLECTION is tested to see if it begins with STRING.
483 The value is a list of all the strings from COLLECTION that match.
485 If COLLECTION is an alist, the cars of the elements of the alist
486 \(which must be strings) form the set of possible completions.
488 If COLLECTION is an obarray, the names of all symbols in the obarray
489 are the possible completions.
491 If COLLECTION is a function, it is called with three arguments: the
492 values STRING, PREDICATE and t. Whatever it returns becomes the
493 value of `all-completions'.
495 If optional third argument PREDICATE is non-nil, it is used to test
496 each possible match. The match is a candidate only if PREDICATE
497 returns non-nil. The argument given to PREDICATE is the alist element
498 or the symbol from the obarray.
500 (string, collection, predicate))
502 /* This function can GC */
504 Lisp_Object allmatches;
511 CHECK_STRING(string);
513 if (CONSP(collection)) {
514 Lisp_Object tem = XCAR(collection);
515 if (SYMBOLP(tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
516 return call3(collection, string, predicate, Qt);
519 } else if (VECTORP(collection))
521 else if (NILP(collection))
524 return call3(collection, string, predicate, Qt);
527 slength = XSTRING_CHAR_LENGTH(string);
529 /* If COLLECTION is not a list, set TAIL just for gc pro. */
532 obsize = XVECTOR_LENGTH(collection);
533 bucket = XVECTOR_DATA(collection)[indice];
534 } else { /* warning suppression */
541 /* Get the next element of the alist or obarray. */
542 /* Exit the loop if the elements are all used up. */
543 /* elt gets the alist element or symbol.
544 eltstring gets the name to check as a completion. */
546 Lisp_Object eltstring;
552 eltstring = Fcar(elt);
555 if (!ZEROP(bucket)) {
557 symbol_next(XSYMBOL(bucket));
559 eltstring = Fsymbol_name(elt);
561 XSETSYMBOL(bucket, next);
564 } else if (++indice >= obsize)
567 bucket = XVECTOR_DATA(collection)[indice];
572 /* Is this element a possible completion? */
574 if (STRINGP(eltstring)
575 && (slength <= XSTRING_CHAR_LENGTH(eltstring))
576 /* Reject alternatives that start with space
577 unless the input starts with space. */
578 && ((XSTRING_CHAR_LENGTH(string) > 0 &&
579 string_char(XSTRING(string), 0) == ' ')
580 || string_char(XSTRING(eltstring), 0) != ' ')
581 && (0 > scmp(XSTRING_DATA(eltstring),
582 XSTRING_DATA(string), slength))) {
583 /* Yes. Now check whether predicate likes it. */
584 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
586 GCPRO4(tail, eltstring, allmatches, string);
587 loser = ignore_completion_p(eltstring, predicate, elt);
590 /* Ok => put it on the list. */
591 allmatches = Fcons(eltstring, allmatches);
595 return Fnreverse(allmatches);
598 /* Useless FSFmacs functions */
599 /* More than useless. I've nuked minibuf_prompt_width so they won't
600 function at all in XEmacs at the moment. They are used to
601 implement some braindamage in FSF which we aren't including. --cet */
604 xxDEFUN("minibuffer-prompt", Fminibuffer_prompt, 0, 0, 0, /*
605 Return the prompt string of the currently-active minibuffer.
606 If no minibuffer is active, return nil.
610 return Fcopy_sequence(Vminibuf_prompt);
613 xxDEFUN("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
614 Return the display width of the minibuffer prompt.
618 return make_int(minibuf_prompt_width);
622 /************************************************************************/
624 /************************************************************************/
626 extern int stdout_needs_newline;
629 clear_echo_area_internal(struct frame *f, Lisp_Object label, int from_print,
632 /* This function can call lisp */
633 if (!NILP(Ffboundp(Qclear_message))) {
637 return call4(Qclear_message, label, frame,
638 from_print ? Qt : Qnil, no_restore ? Qt : Qnil);
640 write_string_to_stdio_stream(stderr, 0, (const Bufbyte *)"\n",
646 Lisp_Object clear_echo_area(struct frame * f, Lisp_Object label, int no_restore)
648 /* This function can call lisp */
649 return clear_echo_area_internal(f, label, 0, no_restore);
653 clear_echo_area_from_print(struct frame * f, Lisp_Object label, int no_restore)
655 /* This function can call lisp */
656 return clear_echo_area_internal(f, label, 1, no_restore);
660 echo_area_append(struct frame *f, const Bufbyte * nonreloc, Lisp_Object reloc,
661 Bytecount offset, Bytecount length, Lisp_Object label)
663 /* This function can call lisp */
664 Lisp_Object obj = Qnil;
668 /* There is an inlining bug in egcs-20000131 c++ that can be worked
669 around as follows: */
670 #if defined (__GNUC__) && defined (__cplusplus)
674 /* some callers pass in a null string as a way of clearing the echo area.
675 check for length == 0 now; if this case, neither nonreloc nor reloc
680 fixup_internal_substring(nonreloc, reloc, offset, &length);
682 /* also check it here, in case the string was really blank. */
686 if (!NILP(Ffboundp(Qappend_message))) {
688 if (STRINGP(reloc) && offset == 0
689 && length == XSTRING_LENGTH(reloc))
693 nonreloc = XSTRING_DATA(reloc);
694 obj = make_string(nonreloc + offset, length);
698 call4(Qappend_message, label, obj, frame,
699 EQ(label, Qprint) ? Qt : Qnil);
703 nonreloc = XSTRING_DATA(reloc);
704 write_string_to_stdio_stream(stderr, 0, nonreloc, offset,
705 length, Qterminal, 0);
710 echo_area_message(struct frame *f, const Bufbyte * nonreloc,
711 Lisp_Object reloc, Bytecount offset, Bytecount length,
714 /* This function can call lisp */
715 clear_echo_area(f, label, 1);
716 echo_area_append(f, nonreloc, reloc, offset, length, label);
719 int echo_area_active(struct frame *f)
721 /* By definition, the echo area is active if the echo-area buffer
722 is not empty. No need to call Lisp code. (Anyway, this function
723 is called from redisplay.) */
724 struct buffer *echo_buffer = XBUFFER(Vecho_area_buffer);
725 return BUF_BEGV(echo_buffer) != BUF_ZV(echo_buffer);
728 Lisp_Object echo_area_status(struct frame * f)
730 /* This function can call lisp */
731 if (!NILP(Ffboundp(Qcurrent_message_label))) {
735 return call1(Qcurrent_message_label, frame);
737 return stdout_needs_newline ? Qmessage : Qnil;
740 Lisp_Object echo_area_contents(struct frame * f)
742 /* See above. By definition, the contents of the echo-area buffer
743 are the contents of the echo area. */
744 return Fbuffer_substring(Qnil, Qnil, Vecho_area_buffer);
747 /* Dump an informative message to the echo area. This function takes a
748 string in internal format. */
750 message_internal(const Bufbyte * nonreloc, Lisp_Object reloc,
751 Bytecount offset, Bytecount length)
753 /* This function can call lisp */
754 if (NILP(Vexecuting_macro))
755 echo_area_message(selected_frame(), nonreloc, reloc, offset,
760 message_append_internal(const Bufbyte * nonreloc, Lisp_Object reloc,
761 Bytecount offset, Bytecount length)
763 /* This function can call lisp */
764 if (NILP(Vexecuting_macro))
765 echo_area_append(selected_frame(), nonreloc, reloc, offset,
769 /* The next three functions are interfaces to message_internal() that
770 take strings in external format. message() does I18N3 translating
771 on the format string; message_no_translate() does not. */
773 static void message_1(const char *fmt, va_list args)
776 /* This function can call lisp */
779 /* message_internal() might GC, e.g. if there are
780 after-change-hooks on the echo area buffer */
781 Lisp_Object obj = Qnil;
784 obj = emacs_doprnt_string_va(
785 (const Bufbyte *)fmt, Qnil, -1, args);
786 message_internal(0, obj, 0, -1);
789 message_internal(0, Qnil, 0, 0);
792 static void message_append_1(const char *fmt, va_list args)
794 /* This function can call lisp */
797 /* message_internal() might GC, e.g. if there are after-change-hooks
798 on the echo area buffer */
800 emacs_doprnt_string_va((const Bufbyte *)fmt, Qnil,
803 message_append_internal(0, obj, 0, -1);
806 message_append_internal(0, Qnil, 0, 0);
809 void clear_message(void)
811 /* This function can call lisp */
812 message_internal(0, Qnil, 0, 0);
815 void message(const char *fmt, ...)
817 /* This function can call lisp */
818 /* I think it's OK to pass the data of Lisp strings as arguments to
819 this function. No GC'ing will occur until the data has already
826 message_1(fmt, args);
830 void message_append(const char *fmt, ...)
832 /* This function can call lisp */
838 message_append_1(fmt, args);
842 void message_no_translate(const char *fmt, ...)
844 /* This function can call lisp */
845 /* I think it's OK to pass the data of Lisp strings as arguments to
846 this function. No GC'ing will occur until the data has already
851 message_1(fmt, args);
855 /************************************************************************/
857 /************************************************************************/
859 void syms_of_minibuf(void)
861 defsymbol(&Qminibuffer_setup_hook, "minibuffer-setup-hook");
863 defsymbol(&Qcompletion_ignore_case, "completion-ignore-case");
865 DEFSUBR(Fminibuffer_depth);
867 DEFSUBR(Fminibuffer_prompt);
868 DEFSUBR(Fminibuffer_prompt_width);
870 DEFSUBR(Fset_minibuffer_preprompt);
871 DEFSUBR(Fread_minibuffer_internal);
873 DEFSUBR(Ftry_completion);
874 DEFSUBR(Fall_completions);
876 defsymbol(&Qappend_message, "append-message");
877 defsymbol(&Qclear_message, "clear-message");
878 defsymbol(&Qdisplay_message, "display-message");
879 defsymbol(&Qcurrent_message_label, "current-message-label");
882 void reinit_vars_of_minibuf(void)
887 void vars_of_minibuf(void)
889 reinit_vars_of_minibuf();
891 staticpro(&Vminibuf_prompt);
892 Vminibuf_prompt = Qnil;
894 /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
895 staticpro(&Vminibuf_preprompt);
896 Vminibuf_preprompt = Qnil;
898 DEFVAR_LISP("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
899 Normal hook run just after entry to minibuffer.
901 Vminibuffer_setup_hook = Qnil;
903 DEFVAR_BOOL("completion-ignore-case", &completion_ignore_case /*
904 Non-nil means don't consider case significant in completion.
906 completion_ignore_case = 0;
908 DEFVAR_LISP("completion-regexp-list", &Vcompletion_regexp_list /*
909 List of regexps that should restrict possible completions.
910 Each completion has to match all regexps in this list.
912 Vcompletion_regexp_list = Qnil;
915 void reinit_complex_vars_of_minibuf(void)
917 /* This function can GC */
919 /* #### This needs to be fixed up so that the gettext() gets called
920 at runtime instead of at load time. */
923 = Fget_buffer_create(build_string(DEFER_GETTEXT(" *Minibuf-0*")));
925 = Fget_buffer_create(build_string(DEFER_GETTEXT(" *Echo Area*")));
928 void complex_vars_of_minibuf(void)
930 reinit_complex_vars_of_minibuf();