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);
390 struct Lisp_Symbol *next;
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 struct 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 /* 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
720 fixup_internal_substring (nonreloc, reloc, offset, &length);
722 /* also check it here, in case the string was really blank. */
726 if (!NILP (Ffboundp (Qappend_message)))
728 if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
733 nonreloc = XSTRING_DATA (reloc);
734 obj = make_string (nonreloc + offset, length);
737 XSETFRAME (frame, f);
739 call4 (Qappend_message, label, obj, frame,
740 EQ (label, Qprint) ? Qt : Qnil);
746 nonreloc = XSTRING_DATA (reloc);
747 write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
753 echo_area_message (struct frame *f, CONST Bufbyte *nonreloc,
754 Lisp_Object reloc, Bytecount offset, Bytecount length,
757 /* This function can call lisp */
758 clear_echo_area (f, label, 1);
759 echo_area_append (f, nonreloc, reloc, offset, length, label);
763 echo_area_active (struct frame *f)
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);
773 echo_area_status (struct frame *f)
775 /* This function can call lisp */
776 if (!NILP (Ffboundp (Qcurrent_message_label)))
780 XSETFRAME (frame, f);
781 return call1 (Qcurrent_message_label, frame);
784 return stdout_needs_newline ? Qmessage : Qnil;
788 echo_area_contents (struct frame *f)
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);
795 /* Dump an informative message to the echo area. This function takes a
796 string in internal format. */
798 message_internal (CONST Bufbyte *nonreloc, Lisp_Object reloc,
799 Bytecount offset, Bytecount length)
801 /* This function can call lisp */
802 if (NILP (Vexecuting_macro))
803 echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
808 message_append_internal (CONST Bufbyte *nonreloc, Lisp_Object reloc,
809 Bytecount offset, Bytecount length)
811 /* This function can call lisp */
812 if (NILP (Vexecuting_macro))
813 echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
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. */
822 message_1 (CONST char *fmt, va_list args)
824 /* This function can call lisp */
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,
833 message_internal (0, obj, 0, -1);
837 message_internal (0, Qnil, 0, 0);
841 message_append_1 (CONST char *fmt, va_list args)
843 /* This function can call lisp */
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,
852 message_append_internal (0, obj, 0, -1);
856 message_append_internal (0, Qnil, 0, 0);
862 /* This function can call lisp */
863 message_internal (0, Qnil, 0, 0);
867 message (CONST char *fmt, ...)
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
875 va_start (args, fmt);
878 message_1 (fmt, args);
883 message_append (CONST char *fmt, ...)
885 /* This function can call lisp */
888 va_start (args, fmt);
891 message_append_1 (fmt, args);
896 message_no_translate (CONST char *fmt, ...)
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
904 va_start (args, fmt);
905 message_1 (fmt, args);
910 /************************************************************************/
912 /************************************************************************/
915 syms_of_minibuf (void)
917 defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
919 defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
921 DEFSUBR (Fminibuffer_depth);
923 DEFSUBR (Fminibuffer_prompt);
924 DEFSUBR (Fminibuffer_prompt_width);
926 DEFSUBR (Fset_minibuffer_preprompt);
927 DEFSUBR (Fread_minibuffer_internal);
929 DEFSUBR (Ftry_completion);
930 DEFSUBR (Fall_completions);
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");
939 vars_of_minibuf (void)
943 staticpro (&Vminibuf_prompt);
944 Vminibuf_prompt = Qnil;
946 /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
947 staticpro (&Vminibuf_preprompt);
948 Vminibuf_preprompt = Qnil;
950 DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
951 Normal hook run just after entry to minibuffer.
953 Vminibuffer_setup_hook = Qnil;
955 DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
956 Non-nil means don't consider case significant in completion.
958 completion_ignore_case = 0;
960 DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
961 List of regexps that should restrict possible completions.
962 Each completion has to match all regexps in this list.
964 Vcompletion_regexp_list = Qnil;
968 complex_vars_of_minibuf (void)
970 /* This function can GC */
972 /* #### This needs to be fixed up so that the gettext() gets called
973 at runtime instead of at load time. */
977 (Fpurecopy (build_string (DEFER_GETTEXT (" *Minibuf-0*"))));
980 (Fpurecopy (build_string (DEFER_GETTEXT (" *Echo Area*"))));