git.chise.org Git - chise/xemacs-chise.git.1/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           && (0 > scmp (XSTRING_DATA (eltstring),
 622                         XSTRING_DATA (string),
 623                         slength)))
 624         {
 625           /* Yes.  Now check whether predicate likes it. */
 626           struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 627           int loser;
 628           GCPRO4 (tail, eltstring, allmatches, string);
 629           loser = ignore_completion_p (eltstring, predicate, elt);
 630           UNGCPRO;
 631           if (!loser)
 632             /* Ok => put it on the list. */
 633             allmatches = Fcons (eltstring, allmatches);
 634         }
 635     }
 636
 637   return Fnreverse (allmatches);
 638 }
 639 \f
 640 /* Useless FSFmacs functions */
 641 /* More than useless.  I've nuked minibuf_prompt_width so they won't
 642    function at all in XEmacs at the moment.  They are used to
 643    implement some braindamage in FSF which we aren't including. --cet */
 644
 645 #if 0
 646 xxDEFUN ("minibuffer-prompt", Fminibuffer_prompt, 0, 0, 0, /*
 647 Return the prompt string of the currently-active minibuffer.
 648 If no minibuffer is active, return nil.
 649 */
 650          ())
 651 {
 652   return Fcopy_sequence (Vminibuf_prompt);
 653 }
 654
 655 xxDEFUN ("minibuffer-prompt-width", Fminibuffer_prompt_width, 0, 0, 0, /*
 656 Return the display width of the minibuffer prompt.
 657 */
 658          ())
 659 {
 660   return make_int (minibuf_prompt_width);
 661 }
 662 #endif /* 0 */
 663
 664 \f
 665 /************************************************************************/
 666 /*                              echo area                               */
 667 /************************************************************************/
 668
 669 extern int stdout_needs_newline;
 670
 671 static Lisp_Object
 672 clear_echo_area_internal (struct frame *f, Lisp_Object label, int from_print,
 673                           int no_restore)
 674 {
 675   /* This function can call lisp */
 676   if (!NILP (Ffboundp (Qclear_message)))
 677     {
 678       Lisp_Object frame;
 679
 680       XSETFRAME (frame, f);
 681       return call4 (Qclear_message, label, frame, from_print ? Qt : Qnil,
 682                     no_restore ? Qt : Qnil);
 683     }
 684   else
 685     {
 686       write_string_to_stdio_stream (stderr, 0, (const Bufbyte *) "\n", 0, 1,
 687                                     Qterminal, 0);
 688       return Qnil;
 689     }
 690 }
 691
 692 Lisp_Object
 693 clear_echo_area (struct frame *f, Lisp_Object label, int no_restore)
 694 {
 695   /* This function can call lisp */
 696   return clear_echo_area_internal (f, label, 0, no_restore);
 697 }
 698
 699 Lisp_Object
 700 clear_echo_area_from_print (struct frame *f, Lisp_Object label, int no_restore)
 701 {
 702   /* This function can call lisp */
 703   return clear_echo_area_internal (f, label, 1, no_restore);
 704 }
 705
 706 void
 707 echo_area_append (struct frame *f, const Bufbyte *nonreloc, Lisp_Object reloc,
 708                   Bytecount offset, Bytecount length,
 709                   Lisp_Object label)
 710 {
 711   /* This function can call lisp */
 712   Lisp_Object obj;
 713   struct gcpro gcpro1;
 714   Lisp_Object frame;
 715
 716   /* There is an inlining bug in egcs-20000131 c++ that can be worked
 717      around as follows:  */
 718 #if defined (__GNUC__) && defined (__cplusplus)
 719   alloca (4);
 720 #endif
 721
 722   /* some callers pass in a null string as a way of clearing the echo area.
 723      check for length == 0 now; if this case, neither nonreloc nor reloc
 724      may be valid.  */
 725   if (length == 0)
 726     return;
 727
 728   fixup_internal_substring (nonreloc, reloc, offset, &length);
 729
 730   /* also check it here, in case the string was really blank. */
 731   if (length == 0)
 732     return;
 733
 734   if (!NILP (Ffboundp (Qappend_message)))
 735     {
 736       if (STRINGP (reloc) && offset == 0 && length == XSTRING_LENGTH (reloc))
 737         obj = reloc;
 738       else
 739         {
 740           if (STRINGP (reloc))
 741             nonreloc = XSTRING_DATA (reloc);
 742           obj = make_string (nonreloc + offset, length);
 743         }
 744
 745       XSETFRAME (frame, f);
 746       GCPRO1 (obj);
 747       call4 (Qappend_message, label, obj, frame,
 748              EQ (label, Qprint) ? Qt : Qnil);
 749       UNGCPRO;
 750     }
 751   else
 752     {
 753       if (STRINGP (reloc))
 754         nonreloc = XSTRING_DATA (reloc);
 755       write_string_to_stdio_stream (stderr, 0, nonreloc, offset, length,
 756                                     Qterminal, 0);
 757     }
 758 }
 759
 760 void
 761 echo_area_message (struct frame *f, const Bufbyte *nonreloc,
 762                    Lisp_Object reloc, Bytecount offset, Bytecount length,
 763                    Lisp_Object label)
 764 {
 765   /* This function can call lisp */
 766   clear_echo_area (f, label, 1);
 767   echo_area_append (f, nonreloc, reloc, offset, length, label);
 768 }
 769
 770 int
 771 echo_area_active (struct frame *f)
 772 {
 773   /* By definition, the echo area is active if the echo-area buffer
 774      is not empty.  No need to call Lisp code. (Anyway, this function
 775      is called from redisplay.) */
 776   struct buffer *echo_buffer = XBUFFER (Vecho_area_buffer);
 777   return BUF_BEGV (echo_buffer) != BUF_ZV (echo_buffer);
 778 }
 779
 780 Lisp_Object
 781 echo_area_status (struct frame *f)
 782 {
 783   /* This function can call lisp */
 784   if (!NILP (Ffboundp (Qcurrent_message_label)))
 785     {
 786       Lisp_Object frame;
 787
 788       XSETFRAME (frame, f);
 789       return call1 (Qcurrent_message_label, frame);
 790     }
 791   else
 792     return stdout_needs_newline ? Qmessage : Qnil;
 793 }
 794
 795 Lisp_Object
 796 echo_area_contents (struct frame *f)
 797 {
 798   /* See above.  By definition, the contents of the echo-area buffer
 799      are the contents of the echo area. */
 800   return Fbuffer_substring (Qnil, Qnil, Vecho_area_buffer);
 801 }
 802
 803 /* Dump an informative message to the echo area.  This function takes a
 804    string in internal format. */
 805 void
 806 message_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
 807                   Bytecount offset, Bytecount length)
 808 {
 809   /* This function can call lisp  */
 810   if (NILP (Vexecuting_macro))
 811     echo_area_message (selected_frame (), nonreloc, reloc, offset, length,
 812                        Qmessage);
 813 }
 814
 815 void
 816 message_append_internal (const Bufbyte *nonreloc, Lisp_Object reloc,
 817                          Bytecount offset, Bytecount length)
 818 {
 819   /* This function can call lisp  */
 820   if (NILP (Vexecuting_macro))
 821     echo_area_append (selected_frame (), nonreloc, reloc, offset, length,
 822                       Qmessage);
 823 }
 824
 825 /* The next three functions are interfaces to message_internal() that
 826    take strings in external format.  message() does I18N3 translating
 827    on the format string; message_no_translate() does not. */
 828
 829 static void
 830 message_1 (const char *fmt, va_list args)
 831 {
 832   /* This function can call lisp */
 833   if (fmt)
 834     {
 835       struct gcpro gcpro1;
 836       /* message_internal() might GC, e.g. if there are after-change-hooks
 837          on the echo area buffer */
 838       Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
 839                                                 -1, args);
 840       GCPRO1 (obj);
 841       message_internal (0, obj, 0, -1);
 842       UNGCPRO;
 843     }
 844   else
 845     message_internal (0, Qnil, 0, 0);
 846 }
 847
 848 static void
 849 message_append_1 (const char *fmt, va_list args)
 850 {
 851   /* This function can call lisp */
 852   if (fmt)
 853     {
 854       struct gcpro gcpro1;
 855       /* message_internal() might GC, e.g. if there are after-change-hooks
 856          on the echo area buffer */
 857       Lisp_Object obj = emacs_doprnt_string_va ((const Bufbyte *) fmt, Qnil,
 858                                                 -1, args);
 859       GCPRO1 (obj);
 860       message_append_internal (0, obj, 0, -1);
 861       UNGCPRO;
 862     }
 863   else
 864     message_append_internal (0, Qnil, 0, 0);
 865 }
 866
 867 void
 868 clear_message (void)
 869 {
 870   /* This function can call lisp */
 871   message_internal (0, Qnil, 0, 0);
 872 }
 873
 874 void
 875 message (const char *fmt, ...)
 876 {
 877   /* This function can call lisp */
 878   /* I think it's OK to pass the data of Lisp strings as arguments to
 879      this function.  No GC'ing will occur until the data has already
 880      been copied. */
 881   va_list args;
 882
 883   va_start (args, fmt);
 884   if (fmt)
 885     fmt = GETTEXT (fmt);
 886   message_1 (fmt, args);
 887   va_end (args);
 888 }
 889
 890 void
 891 message_append (const char *fmt, ...)
 892 {
 893   /* This function can call lisp */
 894   va_list args;
 895
 896   va_start (args, fmt);
 897   if (fmt)
 898     fmt = GETTEXT (fmt);
 899   message_append_1 (fmt, args);
 900   va_end (args);
 901 }
 902
 903 void
 904 message_no_translate (const char *fmt, ...)
 905 {
 906   /* This function can call lisp */
 907   /* I think it's OK to pass the data of Lisp strings as arguments to
 908      this function.  No GC'ing will occur until the data has already
 909      been copied. */
 910   va_list args;
 911
 912   va_start (args, fmt);
 913   message_1 (fmt, args);
 914   va_end (args);
 915 }
 916
 917 \f
 918 /************************************************************************/
 919 /*                            initialization                            */
 920 /************************************************************************/
 921
 922 void
 923 syms_of_minibuf (void)
 924 {
 925   defsymbol (&Qminibuffer_setup_hook, "minibuffer-setup-hook");
 926
 927   defsymbol (&Qcompletion_ignore_case, "completion-ignore-case");
 928
 929   DEFSUBR (Fminibuffer_depth);
 930 #if 0
 931   DEFSUBR (Fminibuffer_prompt);
 932   DEFSUBR (Fminibuffer_prompt_width);
 933 #endif
 934   DEFSUBR (Fset_minibuffer_preprompt);
 935   DEFSUBR (Fread_minibuffer_internal);
 936
 937   DEFSUBR (Ftry_completion);
 938   DEFSUBR (Fall_completions);
 939
 940   defsymbol (&Qappend_message, "append-message");
 941   defsymbol (&Qclear_message, "clear-message");
 942   defsymbol (&Qdisplay_message, "display-message");
 943   defsymbol (&Qcurrent_message_label, "current-message-label");
 944 }
 945
 946 void
 947 reinit_vars_of_minibuf (void)
 948 {
 949   minibuf_level = 0;
 950 }
 951
 952 void
 953 vars_of_minibuf (void)
 954 {
 955   reinit_vars_of_minibuf ();
 956
 957   staticpro (&Vminibuf_prompt);
 958   Vminibuf_prompt = Qnil;
 959
 960   /* Added by Jareth Hein (jhod@po.iijnet.or.jp) for input system support */
 961   staticpro (&Vminibuf_preprompt);
 962   Vminibuf_preprompt = Qnil;
 963
 964   DEFVAR_LISP ("minibuffer-setup-hook", &Vminibuffer_setup_hook /*
 965 Normal hook run just after entry to minibuffer.
 966 */ );
 967   Vminibuffer_setup_hook = Qnil;
 968
 969   DEFVAR_BOOL ("completion-ignore-case", &completion_ignore_case /*
 970 Non-nil means don't consider case significant in completion.
 971 */ );
 972   completion_ignore_case = 0;
 973
 974   DEFVAR_LISP ("completion-regexp-list", &Vcompletion_regexp_list /*
 975 List of regexps that should restrict possible completions.
 976 Each completion has to match all regexps in this list.
 977 */ );
 978   Vcompletion_regexp_list = Qnil;
 979 }
 980
 981 void
 982 reinit_complex_vars_of_minibuf (void)
 983 {
 984   /* This function can GC */
 985 #ifdef I18N3
 986   /* #### This needs to be fixed up so that the gettext() gets called
 987      at runtime instead of at load time. */
 988 #endif
 989   Vminibuffer_zero
 990     = Fget_buffer_create
 991       (build_string (DEFER_GETTEXT (" *Minibuf-0*")));
 992   Vecho_area_buffer
 993     = Fget_buffer_create
 994       (build_string (DEFER_GETTEXT (" *Echo Area*")));
 995 }
 996
 997 void
 998 complex_vars_of_minibuf (void)
 999 {
1000   reinit_complex_vars_of_minibuf ();
1001 }