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 XEmacs.
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
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
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. */
22 /* Synched up with: Mule 2.0, FSF 19.28. Mule-ized except as noted.
23 Substantially different from FSF. */
25 /* #### dmoore - All sorts of things in here can call lisp, like message.
26 Track all this stuff. */
33 #include "console-stream.h"
37 #include "redisplay.h"
40 /* Depth in minibuffer invocations. */
43 Lisp_Object Qcompletion_ignore_case;
45 /* Nonzero means completion ignores case. */
46 int completion_ignore_case;
48 /* List of regexps that should restrict possible completions. */
49 Lisp_Object Vcompletion_regexp_list;
51 /* The echo area buffer. */
52 Lisp_Object Vecho_area_buffer;
54 /* Prompt to display in front of the minibuffer contents */
55 Lisp_Object Vminibuf_prompt;
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;
61 /* Hook to run just after entry to minibuffer. */
62 Lisp_Object Qminibuffer_setup_hook, Vminibuffer_setup_hook;
64 Lisp_Object Qappend_message, Qcurrent_message_label,
65 Qclear_message, Qdisplay_message;
68 DEFUN ("minibuffer-depth", Fminibuffer_depth, 0, 0, 0, /*
69 Return current depth of activations of minibuffer, a nonnegative integer.
73 return make_int (minibuf_level);
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;
81 /* Actual minibuffer invocation. */
84 read_minibuffer_internal_unwind (Lisp_Object unwind_data)
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))
97 Lisp_Object victim = unwind_data;
98 unwind_data = XCDR (unwind_data);
99 free_cons (XCONS (victim));
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);
107 && !NILP (XFRAME (frame)->minibuffer_window))
109 struct window *w = XWINDOW (XFRAME (frame)->minibuffer_window);
110 redisplay_move_cursor (w, 0, 0);
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.
123 if (NILP (preprompt))
125 Vminibuf_preprompt = Qnil;
129 CHECK_STRING (preprompt);
131 Vminibuf_preprompt = LISP_GETTEXT (preprompt);
136 DEFUN ("read-minibuffer-internal", Fread_minibuffer_internal, 1, 1, 0, /*
137 Lowest-level interface to minibuffers. Don't call this.
141 /* This function can GC */
142 int speccount = specpdl_depth ();
145 CHECK_STRING (prompt);
147 single_console_state ();
149 record_unwind_protect (read_minibuffer_internal_unwind,
152 noseeum_cons (make_int (minibuf_level), Qnil)));
153 Vminibuf_prompt = LISP_GETTEXT (prompt);
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.
161 choose_minibuf_frame() does the following:
163 if (!EQ (minibuf_window, selected_frame()->minibuffer_window))
165 Fset_window_buffer (selected_frame()->minibuffer_window,
166 XWINDOW (minibuf_window)->buffer);
167 minibuf_window = selected_frame()->minibuffer_window;
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.
175 The comment above choose_minibuf_frame() reads:
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. */
181 minibuf_window = FRAME_MINIBUF_WINDOW (selected_frame ());
183 run_hook (Qminibuffer_setup_hook);
186 clear_echo_area (selected_frame (), Qnil, 0);
188 val = call_command_loop (Qt);
190 return unbind_to (speccount, val);
195 /* Completion hair */
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. */
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. */
208 scmp_1 (const Bufbyte *s1, const Bufbyte *s2, Charcount len,
217 Emchar c1 = DOWNCASE (current_buffer, charptr_emchar (s1));
218 Emchar c2 = DOWNCASE (current_buffer, charptr_emchar (s2));
232 while (l && charptr_emchar (s1) == charptr_emchar (s2))
247 regexp_ignore_completion_p (const Bufbyte *nonreloc,
248 Lisp_Object reloc, Bytecount offset,
251 /* Ignore this element if it fails to match all the regexps. */
252 if (!NILP (Vcompletion_regexp_list))
255 EXTERNAL_LIST_LOOP (regexps, Vcompletion_regexp_list)
257 Lisp_Object re = XCAR (regexps);
259 if (fast_string_match (re, nonreloc, reloc, offset,
260 length, 0, ERROR_ME, 0) < 0)
268 /* Callers should GCPRO, since this may call eval */
270 ignore_completion_p (Lisp_Object completion_string,
271 Lisp_Object pred, Lisp_Object completion)
273 if (regexp_ignore_completion_p (0, completion_string, 0, -1))
276 /* Ignore this element if there is a predicate
277 and the predicate doesn't like it. */
281 if (EQ (pred, Qcommandp))
282 tem = Fcommandp (completion);
284 tem = call1 (pred, completion);
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.
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? */
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.
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.
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'.
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.
323 (string, alist, pred))
325 /* This function can GC */
326 Lisp_Object bestmatch, tail;
327 Charcount bestmatchsize = 0;
333 Charcount slength, blength;
335 CHECK_STRING (string);
339 Lisp_Object tem = XCAR (alist);
340 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
341 return call3 (alist, string, pred, Qnil);
345 else if (VECTORP (alist))
347 else if (NILP (alist))
350 return call3 (alist, string, pred, Qnil);
354 slength = XSTRING_CHAR_LENGTH (string);
356 /* If ALIST is not a list, set TAIL just for gc pro. */
360 obsize = XVECTOR_LENGTH (alist);
361 bucket = XVECTOR_DATA (alist)[indice];
363 else /* warning suppression */
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. */
376 Lisp_Object eltstring;
383 eltstring = Fcar (elt);
391 if (!SYMBOLP (bucket))
393 signal_simple_error ("Bad obarray passed to try-completions",
396 next = symbol_next (XSYMBOL (bucket));
398 eltstring = Fsymbol_name (elt);
400 XSETSYMBOL (bucket, next);
404 else if (++indice >= obsize)
408 bucket = XVECTOR_DATA (alist)[indice];
413 /* Is this element a possible completion? */
415 if (STRINGP (eltstring))
417 Charcount eltlength = XSTRING_CHAR_LENGTH (eltstring);
418 if (slength <= eltlength
419 && (0 > scmp (XSTRING_DATA (eltstring),
420 XSTRING_DATA (string),
424 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
426 GCPRO4 (tail, string, eltstring, bestmatch);
427 loser = ignore_completion_p (eltstring, pred, elt);
429 if (loser) /* reject this one */
433 /* Update computation of how much all possible
437 if (NILP (bestmatch))
439 bestmatch = eltstring;
441 bestmatchsize = eltlength;
445 Charcount compare = min (bestmatchsize, eltlength);
446 Charcount matchsize =
447 scmp (XSTRING_DATA (bestmatch),
448 XSTRING_DATA (eltstring),
452 if (completion_ignore_case)
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)
461 /* If there is more than one exact match ignoring
462 case, and one of them is exact including case,
464 /* If there is no exact match ignoring case,
465 prefer a match that does not change the case
467 ((matchsize == eltlength)
469 (matchsize == blength)
470 && 0 > scmp_1 (XSTRING_DATA (eltstring),
471 XSTRING_DATA (string),
473 && 0 <= scmp_1 (XSTRING_DATA (bestmatch),
474 XSTRING_DATA (string),
477 bestmatch = eltstring;
481 bestmatchsize = matchsize;
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)
497 /* Return t if the supplied string is an exact match (counting case);
498 it does not require any change to be made. */
500 && bestmatchsize == slength
501 && 0 > scmp_1 (XSTRING_DATA (bestmatch),
502 XSTRING_DATA (string),
506 /* Else extract the part in which all completions agree */
507 return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize));
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.
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'.
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.
528 (string, alist, pred))
530 /* This function can GC */
532 Lisp_Object allmatches;
539 CHECK_STRING (string);
543 Lisp_Object tem = XCAR (alist);
544 if (SYMBOLP (tem)) /* lambda, autoload, etc. Emacs-lisp sucks */
545 return call3 (alist, string, pred, Qt);
549 else if (VECTORP (alist))
551 else if (NILP (alist))
554 return call3 (alist, string, pred, Qt);
557 slength = XSTRING_CHAR_LENGTH (string);
559 /* If ALIST is not a list, set TAIL just for gc pro. */
563 obsize = XVECTOR_LENGTH (alist);
564 bucket = XVECTOR_DATA (alist)[indice];
566 else /* warning suppression */
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. */
579 Lisp_Object eltstring;
586 eltstring = Fcar (elt);
593 Lisp_Symbol *next = symbol_next (XSYMBOL (bucket));
595 eltstring = Fsymbol_name (elt);
597 XSETSYMBOL (bucket, next);
601 else if (++indice >= obsize)
605 bucket = XVECTOR_DATA (alist)[indice];
610 /* Is this element a possible completion? */
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),
623 /* Yes. Now check whether predicate likes it. */
624 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
626 GCPRO4 (tail, eltstring, allmatches, string);
627 loser = ignore_completion_p (eltstring, pred, elt);
630 /* Ok => put it on the list. */
631 allmatches = Fcons (eltstring, allmatches);
635 return Fnreverse (allmatches);
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 */
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.
650 return Fcopy_sequence (Vminibuf_prompt);
653 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
654 Return the display width of the minibuffer prompt.
658 return make_int (minibuf_prompt_width);
663 /************************************************************************/
665 /************************************************************************/
667 extern int stdout_needs_newline;
670 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
673 /* This function can call lisp */
674 if (!NILP (Ffboundp (Qclear_message)))
678 XSETFRAME (frame, f);
679 return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
680 no_restore ? Qt : Qnil);
684 write_string_to_stdio_stream (stderr, 0, (const Bufbyte *) "\n", 0, 1,
691 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
693 /* This function can call lisp */
694 return clear_echo_area_internal (f, label, 0, no_restore);
698 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
700 /* This function can call lisp */
701 return clear_echo_area_internal (f, label, 1, no_restore);
705 echo_area_append (struct frame *f, const Bufbyte *nonreloc, Lisp_Object reloc,
706 Bytecount offset, Bytecount length,
709 /* This function can call lisp */
714 /* There is an inlining bug in egcs-20000131 c++ that can be worked
715 around as follows: */
716 #if defined (__GNUC__) && defined (__cplusplus)
720 /* some callers pass in a null string as a way of clearing the echo area.
721 check for length == 0 now; if this case, neither nonreloc nor reloc
726 fixup_internal_substring (nonreloc, reloc, offset, &length);
728 /* also check it here, in case the string was really blank. */
732 if (!NILP (Ffboundp (Qappend_message)))
734 if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
739 nonreloc = XSTRING_DATA (reloc);
740 obj = make_string (nonreloc + offset, length);
743 XSETFRAME (frame, f);
745 call4 (Qappend_message, label, obj, frame,
746 EQ (label, Qprint) ? Qt : Qnil);
752 nonreloc = XSTRING_DATA (reloc);
753 write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
759 echo_area_message (struct frame *f, const Bufbyte *nonreloc,
760 Lisp_Object reloc, Bytecount offset, Bytecount length,
763 /* This function can call lisp */
764 clear_echo_area (f, label, 1);
765 echo_area_append (f, nonreloc, reloc, offset, length, label);
769 echo_area_active (struct frame *f)
771 /* By definition, the echo area is active if the echo-area buffer
772 is not empty. No need to call Lisp code. (Anyway, this function
773 is called from redisplay.) */
774 struct buffer *echo_buffer = XBUFFER (Vecho_area_buffer);
775 return BUF_BEGV (echo_buffer) != BUF_ZV (echo_buffer);
779 echo_area_status (struct frame *f)
781 /* This function can call lisp */
782 if (!NILP (Ffboundp (Qcurrent_message_label)))
786 XSETFRAME (frame, f);
787 return call1 (Qcurrent_message_label, frame);
790 return stdout_needs_newline ? Qmessage : Qnil;
794 echo_area_contents (struct frame *f)
796 /* See above. By definition, the contents of the echo-area buffer
797 are the contents of the echo area. */
798 return Fbuffer_substring (Qnil, Qnil, Vecho_area_buffer);
801 /* Dump an informative message to the echo area. This function takes a
802 string in internal format. */
804 message_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
805 Bytecount offset, Bytecount length)
807 /* This function can call lisp */
808 if (NILP (Vexecuting_macro))
809 echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
814 message_append_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
815 Bytecount offset, Bytecount length)
817 /* This function can call lisp */
818 if (NILP (Vexecuting_macro))
819 echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
823 /* The next three functions are interfaces to message_internal() that
824 take strings in external format. message() does I18N3 translating
825 on the format string; message_no_translate() does not. */
828 message_1 (const char *fmt, va_list args)
830 /* This function can call lisp */
834 /* message_internal() might GC, e.g. if there are after-change-hooks
835 on the echo area buffer */
836 Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
839 message_internal (0, obj, 0, -1);
843 message_internal (0, Qnil, 0, 0);
847 message_append_1 (const char *fmt, va_list args)
849 /* This function can call lisp */
853 /* message_internal() might GC, e.g. if there are after-change-hooks
854 on the echo area buffer */
855 Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
858 message_append_internal (0, obj, 0, -1);
862 message_append_internal (0, Qnil, 0, 0);
868 /* This function can call lisp */
869 message_internal (0, Qnil, 0, 0);
873 message (const char *fmt, ...)
875 /* This function can call lisp */
876 /* I think it's OK to pass the data of Lisp strings as arguments to
877 this function. No GC'ing will occur until the data has already
881 va_start (args, fmt);
884 message_1 (fmt, args);
889 message_append (const char *fmt, ...)
891 /* This function can call lisp */
894 va_start (args, fmt);
897 message_append_1 (fmt, args);
902 message_no_translate (const char *fmt, ...)
904 /* This function can call lisp */
905 /* I think it's OK to pass the data of Lisp strings as arguments to
906 this function. No GC'ing will occur until the data has already
910 va_start (args, fmt);
911 message_1 (fmt, args);
916 /************************************************************************/
918 /************************************************************************/
921 syms_of_minibuf (void)
923 defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
925 defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
927 DEFSUBR (Fminibuffer_depth);
929 DEFSUBR (Fminibuffer_prompt);
930 DEFSUBR (Fminibuffer_prompt_width);
932 DEFSUBR (Fset_minibuffer_preprompt);
933 DEFSUBR (Fread_minibuffer_internal);
935 DEFSUBR (Ftry_completion);
936 DEFSUBR (Fall_completions);
938 defsymbol (&Qappend_message, "append-message");
939 defsymbol (&Qclear_message, "clear-message");
940 defsymbol (&Qdisplay_message, "display-message");
941 defsymbol (&Qcurrent_message_label, "current-message-label");
945 reinit_vars_of_minibuf (void)
951 vars_of_minibuf (void)
953 reinit_vars_of_minibuf ();
955 staticpro (&Vminibuf_prompt);
956 Vminibuf_prompt = Qnil;
958 /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
959 staticpro (&Vminibuf_preprompt);
960 Vminibuf_preprompt = Qnil;
962 DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
963 Normal hook run just after entry to minibuffer.
965 Vminibuffer_setup_hook = Qnil;
967 DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
968 Non-nil means don't consider case significant in completion.
970 completion_ignore_case = 0;
972 DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
973 List of regexps that should restrict possible completions.
974 Each completion has to match all regexps in this list.
976 Vcompletion_regexp_list = Qnil;
980 reinit_complex_vars_of_minibuf (void)
982 /* This function can GC */
984 /* #### This needs to be fixed up so that the gettext() gets called
985 at runtime instead of at load time. */
989 (build_string (DEFER_GETTEXT (" *Minibuf-0*")));
992 (build_string (DEFER_GETTEXT (" *Echo Area*")));
996 complex_vars_of_minibuf (void)
998 reinit_complex_vars_of_minibuf ();