git.chise.org Git - chise/xemacs-chise.git-/blob - src/minibuf.c

   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 \f
  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 \f
  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 \f
 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 COLLECTION to be a hash table.
 293    It is wrong for the use of obarrays to be better-rewarded than the
 294    use of hash tables.  By better-rewarded I mean that you can pass an
 295    obarray to all of the completion functions, whereas you can't do
 296    anything 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 COLLECTION.
 305 COLLECTION must be an alist, an obarray, or a function.
 306 Each string in COLLECTION is tested to see if it begins with STRING.
 307 All that match are compared together; the longest initial sequence
 308 common to all matches is returned as a string.  If there is no match
 309 at all, nil is returned.  For an exact match, t is returned.
 310
 311 If COLLECTION is an alist, the cars of the elements of the alist
 312 \(which must be strings) form the set of possible completions.
 313
 314 If COLLECTION is an obarray, the names of all symbols in the obarray
 315 are the possible completions.
 316
 317 If COLLECTION is a function, it is called with three arguments: the
 318 values STRING, PREDICATE and nil.  Whatever it returns becomes the
 319 value of `try-completion'.
 320
 321 If optional third argument PREDICATE is non-nil, it is used to test
 322 each possible match.  The match is a candidate only if PREDICATE
 323 returns non-nil.  The argument given to PREDICATE is the alist element
 324 or the symbol from the obarray.
 325 */
 326        (string, collection, predicate))
 327 {
 328   /* This function can GC */
 329   Lisp_Object bestmatch, tail;
 330   Charcount bestmatchsize = 0;
 331   int list;
 332   int indice = 0;
 333   int matchcount = 0;
 334   int obsize;
 335   Lisp_Object bucket;
 336   Charcount slength, blength;
 337
 338   CHECK_STRING (string);
 339
 340   if (CONSP (collection))
 341     {
 342       Lisp_Object tem = XCAR (collection);
 343       if (SYMBOLP (tem))        /* lambda, autoload, etc.  Emacs-lisp sucks */
 344         return call3 (collection, string, predicate, Qnil);
 345       else
 346         list = 1;
 347     }
 348   else if (VECTORP (collection))
 349     list = 0;
 350   else if (NILP (collection))
 351     list = 1;
 352   else
 353     return call3 (collection, string, predicate, Qnil);
 354
 355   bestmatch = Qnil;
 356   blength = 0;
 357   slength = XSTRING_CHAR_LENGTH (string);
 358
 359   /* If COLLECTION is not a list, set TAIL just for gc pro.  */
 360   tail = collection;
 361   if (!list)
 362     {
 363       obsize = XVECTOR_LENGTH (collection);
 364       bucket = XVECTOR_DATA (collection)[indice];
 365     }
 366   else /* warning suppression */
 367     {
 368       obsize = 0;
 369       bucket = Qnil;
 370     }
 371
 372   while (1)
 373     {
 374       /* Get the next element of the alist or obarray. */
 375       /* Exit the loop if the elements are all used up. */
 376       /* elt gets the alist element or symbol.
 377          eltstring gets the name to check as a completion. */
 378       Lisp_Object elt;
 379       Lisp_Object eltstring;
 380
 381       if (list)
 382         {
 383           if (NILP (tail))
 384             break;
 385           elt = Fcar (tail);
 386           eltstring = Fcar (elt);
 387           tail = Fcdr (tail);
 388         }
 389       else
 390         {
 391           if (!ZEROP (bucket))
 392             {
 393               Lisp_Symbol *next;
 394               if (!SYMBOLP (bucket))
 395                 {
 396                   signal_simple_error ("Bad obarray passed to try-completions",
 397                                        bucket);
 398                 }
 399               next = symbol_next (XSYMBOL (bucket));
 400               elt = bucket;
 401               eltstring = Fsymbol_name (elt);
 402               if (next)
 403                 XSETSYMBOL (bucket, next);
 404               else
 405                 bucket = Qzero;
 406             }
 407           else if (++indice >= obsize)
 408             break;
 409           else
 410             {
 411               bucket = XVECTOR_DATA (collection)[indice];
 412               continue;
 413             }
 414         }
 415
 416       /* Is this element a possible completion? */
 417
 418       if (STRINGP (eltstring))
 419         {
 420           Charcount eltlength = XSTRING_CHAR_LENGTH (eltstring);
 421           if (slength <= eltlength
 422               && (0 > scmp (XSTRING_DATA (eltstring),
 423                             XSTRING_DATA (string),
 424                             slength)))
 425             {
 426               {
 427                 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 428                 int loser;
 429                 GCPRO4 (tail, string, eltstring, bestmatch);
 430                 loser = ignore_completion_p (eltstring, predicate, elt);
 431                 UNGCPRO;
 432                 if (loser)      /* reject this one */
 433                   continue;
 434               }
 435
 436               /* Update computation of how much all possible
 437                  completions match */
 438
 439               matchcount++;
 440               if (NILP (bestmatch))
 441                 {
 442                   bestmatch = eltstring;
 443                   blength = eltlength;
 444                   bestmatchsize = eltlength;
 445                 }
 446               else
 447                 {
 448                   Charcount compare = min (bestmatchsize, eltlength);
 449                   Charcount matchsize =
 450                     scmp (XSTRING_DATA (bestmatch),
 451                           XSTRING_DATA (eltstring),
 452                           compare);
 453                   if (matchsize < 0)
 454                     matchsize = compare;
 455                   if (completion_ignore_case)
 456                     {
 457                       /* If this is an exact match except for case,
 458                          use it as the best match rather than one that is not
 459                          an exact match.  This way, we get the case pattern
 460                          of the actual match.  */
 461                       if ((matchsize == eltlength
 462                            && matchsize < blength)
 463                           ||
 464                           /* If there is more than one exact match ignoring
 465                              case, and one of them is exact including case,
 466                              prefer that one.  */
 467                           /* If there is no exact match ignoring case,
 468                              prefer a match that does not change the case
 469                              of the input.  */
 470                           ((matchsize == eltlength)
 471                            ==
 472                            (matchsize == blength)
 473                            && 0 > scmp_1 (XSTRING_DATA (eltstring),
 474                                           XSTRING_DATA (string),
 475                                           slength, 0)
 476                            && 0 <= scmp_1 (XSTRING_DATA (bestmatch),
 477                                            XSTRING_DATA (string),
 478                                            slength, 0)))
 479                       {
 480                         bestmatch = eltstring;
 481                         blength = eltlength;
 482                       }
 483                     }
 484                   bestmatchsize = matchsize;
 485                 }
 486             }
 487         }
 488     }
 489
 490   if (NILP (bestmatch))
 491     return Qnil;                /* No completions found */
 492   /* If we are ignoring case, and there is no exact match,
 493      and no additional text was supplied,
 494      don't change the case of what the user typed.  */
 495   if (completion_ignore_case
 496       && bestmatchsize == slength
 497       && blength > bestmatchsize)
 498     return string;
 499
 500   /* Return t if the supplied string is an exact match (counting case);
 501      it does not require any change to be made.  */
 502   if (matchcount == 1
 503       && bestmatchsize == slength
 504       && 0 > scmp_1 (XSTRING_DATA (bestmatch),
 505                      XSTRING_DATA (string),
 506                      bestmatchsize, 0))
 507     return Qt;
 508
 509   /* Else extract the part in which all completions agree */
 510   return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize));
 511 }
 512
 513 \f
 514 DEFUN ("all-completions", Fall_completions, 2, 3, 0, /*
 515 Search for partial matches to STRING in COLLECTION.
 516 COLLECTION must be an alist, an obarray, or a function.
 517 Each string in COLLECTION is tested to see if it begins with STRING.
 518 The value is a list of all the strings from COLLECTION that match.
 519
 520 If COLLECTION is an alist, the cars of the elements of the alist
 521 \(which must be strings) form the set of possible completions.
 522
 523 If COLLECTION is an obarray, the names of all symbols in the obarray
 524 are the possible completions.
 525
 526 If COLLECTION is a function, it is called with three arguments: the
 527 values STRING, PREDICATE and t.  Whatever it returns becomes the
 528 value of `all-completions'.
 529
 530 If optional third argument PREDICATE is non-nil, it is used to test
 531 each possible match.  The match is a candidate only if PREDICATE
 532 returns non-nil.  The argument given to PREDICATE is the alist element
 533 or the symbol from the obarray.
 534 */
 535        (string, collection, predicate))
 536 {
 537   /* This function can GC */
 538   Lisp_Object tail;
 539   Lisp_Object allmatches;
 540   int list;
 541   int indice = 0;
 542   int obsize;
 543   Lisp_Object bucket;
 544   Charcount slength;
 545
 546   CHECK_STRING (string);
 547
 548   if (CONSP (collection))
 549     {
 550       Lisp_Object tem = XCAR (collection);
 551       if (SYMBOLP (tem))        /* lambda, autoload, etc.  Emacs-lisp sucks */
 552         return call3 (collection, string, predicate, Qt);
 553       else
 554         list = 1;
 555     }
 556   else if (VECTORP (collection))
 557     list = 0;
 558   else if (NILP (collection))
 559     list = 1;
 560   else
 561     return call3 (collection, string, predicate, Qt);
 562
 563   allmatches = Qnil;
 564   slength = XSTRING_CHAR_LENGTH (string);
 565
 566   /* If COLLECTION is not a list, set TAIL just for gc pro.  */
 567   tail = collection;
 568   if (!list)
 569     {
 570       obsize = XVECTOR_LENGTH (collection);
 571       bucket = XVECTOR_DATA (collection)[indice];
 572     }
 573   else /* warning suppression */
 574     {
 575       obsize = 0;
 576       bucket = Qnil;
 577     }
 578
 579   while (1)
 580     {
 581       /* Get the next element of the alist or obarray. */
 582       /* Exit the loop if the elements are all used up. */
 583       /* elt gets the alist element or symbol.
 584          eltstring gets the name to check as a completion. */
 585       Lisp_Object elt;
 586       Lisp_Object eltstring;
 587
 588       if (list)
 589         {
 590           if (NILP (tail))
 591             break;
 592           elt = Fcar (tail);
 593           eltstring = Fcar (elt);
 594           tail = Fcdr (tail);
 595         }
 596       else
 597         {
 598           if (!ZEROP (bucket))
 599             {
 600               Lisp_Symbol *next = symbol_next (XSYMBOL (bucket));
 601               elt = bucket;
 602               eltstring = Fsymbol_name (elt);
 603               if (next)
 604                 XSETSYMBOL (bucket, next);
 605               else
 606                 bucket = Qzero;
 607             }
 608           else if (++indice >= obsize)
 609             break;
 610           else
 611             {
 612               bucket = XVECTOR_DATA (collection)[indice];
 613               continue;
 614             }
 615         }
 616
 617       /* Is this element a possible completion? */
 618
 619       if (STRINGP (eltstring)
 620           && (slength <= XSTRING_CHAR_LENGTH (eltstring))
 621           /* Reject alternatives that start with space
 622              unless the input starts with space.  */
 623           && ((XSTRING_CHAR_LENGTH (string) > 0 &&
 624                string_char (XSTRING (string), 0) == ' ')
 625               || string_char (XSTRING (eltstring), 0) != ' ')
 626           && (0 > scmp (XSTRING_DATA (eltstring),
 627                         XSTRING_DATA (string),
 628                         slength)))
 629         {
 630           /* Yes.  Now check whether predicate likes it. */
 631           struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 632           int loser;
 633           GCPRO4 (tail, eltstring, allmatches, string);
 634           loser = ignore_completion_p (eltstring, predicate, elt);
 635           UNGCPRO;
 636           if (!loser)
 637             /* Ok => put it on the list. */
 638             allmatches = Fcons (eltstring, allmatches);
 639         }
 640     }
 641
 642   return Fnreverse (allmatches);
 643 }
 644 \f
 645 /* Useless FSFmacs functions */
 646 /* More than useless.  I've nuked minibuf_prompt_width so they won't
 647    function at all in XEmacs at the moment.  They are used to
 648    implement some braindamage in FSF which we aren't including. --cet */
 649
 650 #if 0
 651 xxDEFUN ("minibuffer-prompt", Fminibuffer_prompt, 0, 0, 0, /*
 652 Return the prompt string of the currently-active minibuffer.
 653 If no minibuffer is active, return nil.
 654 */
 655          ())
 656 {
 657   return Fcopy_sequence (Vminibuf_prompt);
 658 }
 659
 660 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
 661 Return the display width of the minibuffer prompt.
 662 */
 663          ())
 664 {
 665   return make_int (minibuf_prompt_width);
 666 }
 667 #endif /* 0 */
 668
 669 \f
 670 /************************************************************************/
 671 /*                              echo area                               */
 672 /************************************************************************/
 673
 674 extern int stdout_needs_newline;
 675
 676 static Lisp_Object
 677 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
 678                           int no_restore)
 679 {
 680   /* This function can call lisp */
 681   if (!NILP (Ffboundp (Qclear_message)))
 682     {
 683       Lisp_Object frame;
 684
 685       XSETFRAME (frame, f);
 686       return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
 687                     no_restore ? Qt : Qnil);
 688     }
 689   else
 690     {
 691       write_string_to_stdio_stream (stderr, 0, (const Bufbyte *) "\n", 0, 1,
 692                                     Qterminal, 0);
 693       return Qnil;
 694     }
 695 }
 696
 697 Lisp_Object
 698 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
 699 {
 700   /* This function can call lisp */
 701   return clear_echo_area_internal (f, label, 0, no_restore);
 702 }
 703
 704 Lisp_Object
 705 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
 706 {
 707   /* This function can call lisp */
 708   return clear_echo_area_internal (f, label, 1, no_restore);
 709 }
 710
 711 void
 712 echo_area_append (struct frame *f, const Bufbyte *nonreloc, Lisp_Object reloc,
 713                   Bytecount offset, Bytecount length,
 714                   Lisp_Object label)
 715 {
 716   /* This function can call lisp */
 717   Lisp_Object obj;
 718   struct gcpro gcpro1;
 719   Lisp_Object frame;
 720
 721   /* There is an inlining bug in egcs-20000131 c++ that can be worked
 722      around as follows:  */
 723 #if defined (__GNUC__) && defined (__cplusplus)
 724   alloca (4);
 725 #endif
 726
 727   /* some callers pass in a null string as a way of clearing the echo area.
 728      check for length == 0 now; if this case, neither nonreloc nor reloc
 729      may be valid.  */
 730   if (length == 0)
 731     return;
 732
 733   fixup_internal_substring (nonreloc, reloc, offset, &length);
 734
 735   /* also check it here, in case the string was really blank. */
 736   if (length == 0)
 737     return;
 738
 739   if (!NILP (Ffboundp (Qappend_message)))
 740     {
 741       if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
 742         obj = reloc;
 743       else
 744         {
 745           if (STRINGP (reloc))
 746             nonreloc = XSTRING_DATA (reloc);
 747           obj = make_string (nonreloc + offset, length);
 748         }
 749
 750       XSETFRAME (frame, f);
 751       GCPRO1 (obj);
 752       call4 (Qappend_message, label, obj, frame,
 753              EQ (label, Qprint) ? Qt : Qnil);
 754       UNGCPRO;
 755     }
 756   else
 757     {
 758       if (STRINGP (reloc))
 759         nonreloc = XSTRING_DATA (reloc);
 760       write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
 761                                     Qterminal, 0);
 762     }
 763 }
 764
 765 void
 766 echo_area_message (struct frame *f, const Bufbyte *nonreloc,
 767                    Lisp_Object reloc, Bytecount offset, Bytecount length,
 768                    Lisp_Object label)
 769 {
 770   /* This function can call lisp */
 771   clear_echo_area (f, label, 1);
 772   echo_area_append (f, nonreloc, reloc, offset, length, label);
 773 }
 774
 775 int
 776 echo_area_active (struct frame *f)
 777 {
 778   /* By definition, the echo area is active if the echo-area buffer
 779      is not empty.  No need to call Lisp code. (Anyway, this function
 780      is called from redisplay.) */
 781   struct buffer *echo_buffer = XBUFFER (Vecho_area_buffer);
 782   return BUF_BEGV (echo_buffer) != BUF_ZV (echo_buffer);
 783 }
 784
 785 Lisp_Object
 786 echo_area_status (struct frame *f)
 787 {
 788   /* This function can call lisp */
 789   if (!NILP (Ffboundp (Qcurrent_message_label)))
 790     {
 791       Lisp_Object frame;
 792
 793       XSETFRAME (frame, f);
 794       return call1 (Qcurrent_message_label, frame);
 795     }
 796   else
 797     return stdout_needs_newline ? Qmessage : Qnil;
 798 }
 799
 800 Lisp_Object
 801 echo_area_contents (struct frame *f)
 802 {
 803   /* See above.  By definition, the contents of the echo-area buffer
 804      are the contents of the echo area. */
 805   return Fbuffer_substring (Qnil, Qnil, Vecho_area_buffer);
 806 }
 807
 808 /* Dump an informative message to the echo area.  This function takes a
 809    string in internal format. */
 810 void
 811 message_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
 812                   Bytecount offset, Bytecount length)
 813 {
 814   /* This function can call lisp  */
 815   if (NILP (Vexecuting_macro))
 816     echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
 817                        Qmessage);
 818 }
 819
 820 void
 821 message_append_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
 822                          Bytecount offset, Bytecount length)
 823 {
 824   /* This function can call lisp  */
 825   if (NILP (Vexecuting_macro))
 826     echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
 827                       Qmessage);
 828 }
 829
 830 /* The next three functions are interfaces to message_internal() that
 831    take strings in external format.  message() does I18N3 translating
 832    on the format string; message_no_translate() does not. */
 833
 834 static void
 835 message_1 (const char *fmt, va_list args)
 836 {
 837   /* This function can call lisp */
 838   if (fmt)
 839     {
 840       struct gcpro gcpro1;
 841       /* message_internal() might GC, e.g. if there are after-change-hooks
 842          on the echo area buffer */
 843       Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
 844                                                 -1, args);
 845       GCPRO1 (obj);
 846       message_internal (0, obj, 0, -1);
 847       UNGCPRO;
 848     }
 849   else
 850     message_internal (0, Qnil, 0, 0);
 851 }
 852
 853 static void
 854 message_append_1 (const char *fmt, va_list args)
 855 {
 856   /* This function can call lisp */
 857   if (fmt)
 858     {
 859       struct gcpro gcpro1;
 860       /* message_internal() might GC, e.g. if there are after-change-hooks
 861          on the echo area buffer */
 862       Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
 863                                                 -1, args);
 864       GCPRO1 (obj);
 865       message_append_internal (0, obj, 0, -1);
 866       UNGCPRO;
 867     }
 868   else
 869     message_append_internal (0, Qnil, 0, 0);
 870 }
 871
 872 void
 873 clear_message (void)
 874 {
 875   /* This function can call lisp */
 876   message_internal (0, Qnil, 0, 0);
 877 }
 878
 879 void
 880 message (const char *fmt, ...)
 881 {
 882   /* This function can call lisp */
 883   /* I think it's OK to pass the data of Lisp strings as arguments to
 884      this function.  No GC'ing will occur until the data has already
 885      been copied. */
 886   va_list args;
 887
 888   va_start (args, fmt);
 889   if (fmt)
 890     fmt = GETTEXT (fmt);
 891   message_1 (fmt, args);
 892   va_end (args);
 893 }
 894
 895 void
 896 message_append (const char *fmt, ...)
 897 {
 898   /* This function can call lisp */
 899   va_list args;
 900
 901   va_start (args, fmt);
 902   if (fmt)
 903     fmt = GETTEXT (fmt);
 904   message_append_1 (fmt, args);
 905   va_end (args);
 906 }
 907
 908 void
 909 message_no_translate (const char *fmt, ...)
 910 {
 911   /* This function can call lisp */
 912   /* I think it's OK to pass the data of Lisp strings as arguments to
 913      this function.  No GC'ing will occur until the data has already
 914      been copied. */
 915   va_list args;
 916
 917   va_start (args, fmt);
 918   message_1 (fmt, args);
 919   va_end (args);
 920 }
 921
 922 \f
 923 /************************************************************************/
 924 /*                            initialization                            */
 925 /************************************************************************/
 926
 927 void
 928 syms_of_minibuf (void)
 929 {
 930   defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
 931
 932   defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
 933
 934   DEFSUBR (Fminibuffer_depth);
 935 #if 0
 936   DEFSUBR (Fminibuffer_prompt);
 937   DEFSUBR (Fminibuffer_prompt_width);
 938 #endif
 939   DEFSUBR (Fset_minibuffer_preprompt);
 940   DEFSUBR (Fread_minibuffer_internal);
 941
 942   DEFSUBR (Ftry_completion);
 943   DEFSUBR (Fall_completions);
 944
 945   defsymbol (&Qappend_message, "append-message");
 946   defsymbol (&Qclear_message, "clear-message");
 947   defsymbol (&Qdisplay_message, "display-message");
 948   defsymbol (&Qcurrent_message_label, "current-message-label");
 949 }
 950
 951 void
 952 reinit_vars_of_minibuf (void)
 953 {
 954   minibuf_level = 0;
 955 }
 956
 957 void
 958 vars_of_minibuf (void)
 959 {
 960   reinit_vars_of_minibuf ();
 961
 962   staticpro (&Vminibuf_prompt);
 963   Vminibuf_prompt = Qnil;
 964
 965   /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
 966   staticpro (&Vminibuf_preprompt);
 967   Vminibuf_preprompt = Qnil;
 968
 969   DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
 970 Normal hook run just after entry to minibuffer.
 971 */ );
 972   Vminibuffer_setup_hook = Qnil;
 973
 974   DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
 975 Non-nil means don't consider case significant in completion.
 976 */ );
 977   completion_ignore_case = 0;
 978
 979   DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
 980 List of regexps that should restrict possible completions.
 981 Each completion has to match all regexps in this list.
 982 */ );
 983   Vcompletion_regexp_list = Qnil;
 984 }
 985
 986 void
 987 reinit_complex_vars_of_minibuf (void)
 988 {
 989   /* This function can GC */
 990 #ifdef I18N3
 991   /* #### This needs to be fixed up so that the gettext() gets called
 992      at runtime instead of at load time. */
 993 #endif
 994   Vminibuffer_zero
 995     = Fget_buffer_create
 996       (build_string (DEFER_GETTEXT (" *Minibuf-0*")));
 997   Vecho_area_buffer
 998     = Fget_buffer_create
 999       (build_string (DEFER_GETTEXT (" *Echo Area*")));
1000 }
1001
1002 void
1003 complex_vars_of_minibuf (void)
1004 {
1005   reinit_complex_vars_of_minibuf ();
1006 }