src/callint.c

   1 /* Call a Lisp function interactively.
   2    Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 1, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19
  20
  21 #include "config.h"
  22 #include "lisp.h"
  23 #include "buffer.h"
  24 #include "commands.h"
  25 #include "keyboard.h"
  26 #include "window.h"
  27 #include "mocklisp.h"
  28
  29 extern char *index ();
  30
  31 Lisp_Object Vprefix_arg, Vcurrent_prefix_arg, Qminus;
  32 Lisp_Object Qcall_interactively;
  33 Lisp_Object Vcommand_history;
  34
  35 Lisp_Object Vcommand_debug_status, Qcommand_debug_status;
  36
  37 /* This comment supplies the doc string for interactive,
  38    for make-docfile to see.  We cannot put this in the real DEFUN
  39    due to limits in the Unix cpp.
  40
  41 DEFUN ("interactive", Ffoo, Sfoo, 0, 0, 0,
  42  "Specify a way of parsing arguments for interactive use of a function.\n\
  43 For example, write\n\
  44   (defun foo (arg) \"Doc string\" (interactive \"p\") ...use arg...)\n\
  45 to make ARG be the prefix argument when `foo' is called as a command.\n\
  46 The \"call\" to `interactive' is actually a declaration rather than a function;\n\
  47  it tells `call-interactively' how to read arguments\n\
  48  to pass to the function.\n\
  49 When actually called, `interactive' just returns nil.\n\
  50 \n\
  51 The argument of `interactive' is usually a string containing a code letter\n\
  52  followed by a prompt.  (Some code letters do not use I/O to get\n\
  53  the argument and do not need prompts.)  To prompt for multiple arguments,\n\
  54  give a code letter, its prompt, a newline, and another code letter, etc.\n\
  55  Prompts are passed to format, and may use % escapes to print the\n\
  56  arguments that have already been read.\n\
  57 If the argument is not a string, it is evaluated to get a list of\n\
  58  arguments to pass to the function.\n\
  59 Just `(interactive)' means pass no args when calling interactively.\n\
  60 \nCode letters available are:\n\
  61 a -- Function name: symbol with a function definition.\n\
  62 b -- Name of existing buffer.\n\
  63 B -- Name of buffer, possibly nonexistent.\n\
  64 c -- Character.\n\
  65 C -- Command name: symbol with interactive function definition.\n\
  66 d -- Value of point as number.  Does not do I/O.\n\
  67 D -- Directory name.\n\
  68 f -- Existing file name.\n\
  69 F -- Possibly nonexistent file name.\n\
  70 k -- Key sequence (string).\n\
  71 K -- Mouse click that invoked this command - last-command-char.\n\
  72 m -- Value of mark as number.  Does not do I/O.\n\
  73 n -- Number read using minibuffer.\n\
  74 N -- Prefix arg converted to number, or if none, do like code `n'.\n\
  75 p -- Prefix arg converted to number.  Does not do I/O.\n\
  76 P -- Prefix arg in raw form.  Does not do I/O.\n\
  77 r -- Region: point and mark as 2 numeric args, smallest first.  Does no I/O.\n\
  78 s -- Any string.\n\
  79 S -- Any symbol.\n\
  80 v -- Variable name: symbol that is user-variable-p.\n\
  81 x -- Lisp expression read but not evaluated.\n\
  82 X -- Lisp expression read and evaluated.\n\
  83 In addition, if the string begins with `*'\n\
  84  then an error is signaled if the buffer is read-only.\n\
  85  This happens before reading any arguments.\n\
  86 If the string begins with `@', then the window the mouse is over is selected\n\
  87  before anything else is done.  You may use both `@' and `*';\n\
  88 they are processed in the order that they appear."
  89 */
  90
  91 /* ARGSUSED */
  92 DEFUN ("interactive", Finteractive, Sinteractive, 0, UNEVALLED, 0,
  93   0 /* See immediately above */)
  94   (args)
  95      Lisp_Object args;
  96 {
  97   return Qnil;
  98 }
  99
 100 /* Quotify EXP: if EXP is constant, return it.
 101    If EXP is not constant, return (quote EXP).  */
 102 Lisp_Object
 103 quotify_arg (exp)
 104      register Lisp_Object exp;
 105 {
 106   if (XTYPE (exp) != Lisp_Int && XTYPE (exp) != Lisp_String
 107       && !NILP (exp) && !EQ (exp, Qt))
 108     return Fcons (Qquote, Fcons (exp, Qnil));
 109
 110   return exp;
 111 }
 112
 113 /* Modify EXP by quotifying each element (except the first).  */
 114 Lisp_Object
 115 quotify_args (exp)
 116      Lisp_Object exp;
 117 {
 118   register Lisp_Object tail;
 119   register struct Lisp_Cons *ptr;
 120   for (tail = exp; CONSP (tail); tail = ptr->cdr)
 121     {
 122       ptr = XCONS (tail);
 123       ptr->car = quotify_arg (ptr->car);
 124     }
 125   return exp;
 126 }
 127
 128 char *callint_argfuns[]
 129     = {"", "point", "mark", "region-beginning", "region-end"};
 130
 131 static void
 132 check_mark ()
 133 {
 134   Lisp_Object tem = Fmarker_buffer (current_buffer->mark);
 135   if (NILP (tem) || (XBUFFER (tem) != current_buffer))
 136     error ("The mark is not set now");
 137 }
 138
 139
 140 DEFUN ("call-interactively", Fcall_interactively, Scall_interactively, 1, 2, 0,
 141   "Call FUNCTION, reading args according to its interactive calling specs.\n\
 142 The function contains a specification of how to do the argument reading.\n\
 143 In the case of user-defined functions, this is specified by placing a call\n\
 144 to the function `interactive' at the top level of the function body.\n\
 145 See `interactive'.\n\
 146 \n\
 147 Optional second arg RECORD-FLAG non-nil\n\
 148 means unconditionally put this command in the command-history.\n\
 149 Otherwise, this is done only if an arg is read using the minibuffer.")
 150   (function, record)
 151      Lisp_Object function, record;
 152 {
 153   Lisp_Object *args, *visargs;
 154   unsigned char **argstrings;
 155   Lisp_Object fun;
 156   Lisp_Object funcar;
 157   Lisp_Object specs;
 158   Lisp_Object teml;
 159
 160   Lisp_Object prefix_arg;
 161   unsigned char *string;
 162   unsigned char *tem;
 163
 164   /* If varies[i] > 0, the i'th argument shouldn't just have its value
 165      in this call quoted in the command history.  It should be
 166      recorded as a call to the function named callint_argfuns[varies[i]].  */
 167   int *varies;
 168
 169   register int i, j;
 170   int count, foo;
 171   char prompt[100];
 172   char prompt1[100];
 173   char *tem1;
 174   int arg_from_tty = 0;
 175   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 176
 177   /* Save this now, since use of minibuffer will clobber it. */
 178   prefix_arg = Vcurrent_prefix_arg;
 179
 180  retry:
 181
 182   fun = indirect_function (function);
 183
 184   specs = Qnil;
 185   string = 0;
 186
 187   /* Decode the kind of function.  Either handle it and return,
 188      or go to `lose' if not interactive, or go to `retry'
 189      to specify a different function, or set either STRING or SPECS.  */
 190
 191   if (XTYPE (fun) == Lisp_Subr)
 192     {
 193       string = (unsigned char *) XSUBR (fun)->prompt;
 194       if (!string)
 195         {
 196         lose:
 197           function = wrong_type_argument (Qcommandp, function, 0);
 198           goto retry;
 199         }
 200       if ((int) string == 1)
 201         /* Let SPECS (which is nil) be used as the args.  */
 202         string = 0;
 203     }
 204   else if (XTYPE (fun) == Lisp_Compiled)
 205     {
 206       if (XVECTOR (fun)->size <= COMPILED_INTERACTIVE)
 207         goto lose;
 208       specs = XVECTOR (fun)->contents[COMPILED_INTERACTIVE];
 209     }
 210   else if (!CONSP (fun))
 211     goto lose;
 212   else if (funcar = Fcar (fun), EQ (funcar, Qautoload))
 213     {
 214       GCPRO2 (function, prefix_arg);
 215       do_autoload (fun, function);
 216       UNGCPRO;
 217       goto retry;
 218     }
 219   else if (EQ (funcar, Qlambda))
 220     {
 221       specs = Fassq (Qinteractive, Fcdr (Fcdr (fun)));
 222       if (NILP (specs))
 223         goto lose;
 224       specs = Fcar (Fcdr (specs));
 225     }
 226   else if (EQ (funcar, Qmocklisp))
 227     return ml_apply (fun, Qinteractive);
 228   else
 229     goto lose;
 230
 231   /* If either specs or string is set to a string, use it.  */
 232   if (XTYPE (specs) == Lisp_String)
 233     {
 234       /* Make a copy of string so that if a GC relocates specs,
 235          `string' will still be valid.  */
 236       string = (unsigned char *) alloca (XSTRING (specs)->size + 1);
 237       bcopy (XSTRING (specs)->data, string, XSTRING (specs)->size + 1);
 238     }
 239   else if (string == 0)
 240     {
 241       i = num_input_chars;
 242       specs = Feval (specs);
 243       if (i != num_input_chars || !NILP (record))
 244         Vcommand_history
 245           = Fcons (Fcons (function, quotify_args (Fcopy_sequence (specs))),
 246                    Vcommand_history);
 247       return apply1 (function, specs);
 248     }
 249
 250   /* Here if function specifies a string to control parsing the defaults */
 251
 252   /* Handle special starting chars `*' and `@'.  */
 253   while (1)
 254     {
 255       if (*string == '*')
 256         {
 257           string++;
 258           if (!NILP (current_buffer->read_only))
 259             Fbarf_if_buffer_read_only ();
 260         }
 261       else if (*string == '@')
 262         {
 263           string++;
 264           if (!NILP (Vmouse_window))
 265             Fselect_window (Vmouse_window);
 266         }
 267       else break;
 268     }
 269
 270   /* Count the number of arguments the interactive spec would have
 271      us give to the function.  */
 272   tem = string;
 273   for (j = 0; *tem; j++)
 274     {
 275       /* 'r' specifications ("point and mark as 2 numeric args")
 276          produce *two* arguments.  */
 277       if (*tem == 'r') j++;
 278       tem = (unsigned char *) index (tem, '\n');
 279       if (tem)
 280         tem++;
 281       else
 282         tem = (unsigned char *) "";
 283     }
 284   count = j;
 285
 286   args = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
 287   visargs = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
 288   argstrings = (unsigned char **) alloca ((count + 1) * sizeof (char *));
 289   varies = (int *) alloca ((count + 1) * sizeof (int));
 290
 291   for (i = 0; i < (count + 1); i++)
 292     {
 293       args[i] = Qnil;
 294       visargs[i] = Qnil;
 295       varies[i] = 0;
 296     }
 297
 298   GCPRO4 (prefix_arg, function, *args, *visargs);
 299   gcpro3.nvars = (count + 1);
 300   gcpro4.nvars = (count + 1);
 301
 302   tem = string;
 303   for (i = 1; *tem; i++)
 304     {
 305       strncpy (prompt1, tem + 1, sizeof prompt1 - 1);
 306       prompt1[sizeof prompt1 - 1] = 0;
 307       tem1 = index (prompt1, '\n');
 308       if (tem1) *tem1 = 0;
 309       /* Fill argstrings with a vector of C strings
 310          corresponding to the Lisp strings in visargs.  */
 311       for (j = 1; j < i; j++)
 312         argstrings[j]
 313           = EQ (visargs[j], Qnil)
 314             ? (unsigned char *) ""
 315               : XSTRING (visargs[j])->data;
 316
 317       doprnt (prompt, sizeof prompt, prompt1, 0, j - 1, argstrings + 1);
 318
 319       switch (*tem)
 320         {
 321         case 'a':               /* Symbol defined as a function */
 322           visargs[i] = Fcompleting_read (build_string (prompt),
 323                                          Vobarray, Qfboundp, Qt, Qnil, Qnil);
 324           /* Passing args[i] directly stimulates compiler bug */
 325           teml = visargs[i];
 326           args[i] = Fintern (teml, Qnil);
 327           break;
 328
 329         case 'b':               /* Name of existing buffer */
 330           args[i] = Fcurrent_buffer ();
 331           if (EQ (selected_window, minibuf_window))
 332             args[i] = Fother_buffer (args[i]);
 333           args[i] = Fread_buffer (build_string (prompt), args[i], Qt);
 334           break;
 335
 336         case 'B':               /* Name of buffer, possibly nonexistent */
 337           args[i] = Fread_buffer (build_string (prompt),
 338                                   Fother_buffer (Fcurrent_buffer ()), Qnil);
 339           break;
 340
 341         case 'c':               /* Character */
 342           message1 (prompt);
 343           args[i] = Fread_char ();
 344           /* Passing args[i] directly stimulates compiler bug */
 345           teml = args[i];
 346           visargs[i] = Fchar_to_string (teml);
 347           break;
 348
 349         case 'C':               /* Command: symbol with interactive function */
 350           visargs[i] = Fcompleting_read (build_string (prompt),
 351                                          Vobarray, Qcommandp, Qt, Qnil, Qnil);
 352           /* Passing args[i] directly stimulates compiler bug */
 353           teml = visargs[i];
 354           args[i] = Fintern (teml, Qnil);
 355           break;
 356
 357         case 'd':               /* Value of point.  Does not do I/O.  */
 358           XFASTINT (args[i]) = point;
 359           /* visargs[i] = Qnil; */
 360           varies[i] = 1;
 361           break;
 362
 363         case 'D':               /* Directory name. */
 364           args[i] = Fread_file_name (build_string (prompt), Qnil,
 365                                      current_buffer->directory, Qlambda, Qnil);
 366           break;
 367
 368         case 'f':               /* Existing file name. */
 369           args[i] = Fread_file_name (build_string (prompt),
 370                                      Qnil, Qnil, Qlambda, Qnil);
 371           break;
 372
 373         case 'F':               /* Possibly nonexistent file name. */
 374           args[i] = Fread_file_name (build_string (prompt),
 375                                      Qnil, Qnil, Qnil, Qnil);
 376           break;
 377
 378         case 'k':               /* Key sequence (string) */
 379           args[i] = Fread_key_sequence (build_string (prompt), Qnil);
 380           teml = args[i];
 381           visargs[i] = Fkey_description (teml);
 382           break;
 383
 384         case 'K':               /* Mouse click.  */
 385           args[i] = last_command_char;
 386           if (NILP (Fmouse_click_p (args[i])))
 387             error ("%s must be bound to a mouse click.",
 388                    (XTYPE (function) == Lisp_Symbol
 389                     ? (char *) XSYMBOL (function)->name->data
 390                     : "Command"));
 391           varies[i] = -1;
 392           break;
 393
 394         case 'm':               /* Value of mark.  Does not do I/O.  */
 395           check_mark ();
 396           /* visargs[i] = Qnil; */
 397           XFASTINT (args[i]) = marker_position (current_buffer->mark);
 398           varies[i] = 2;
 399           break;
 400
 401         case 'N':               /* Prefix arg, else number from minibuffer */
 402           if (!NILP (prefix_arg))
 403             goto have_prefix_arg;
 404         case 'n':               /* Read number from minibuffer.  */
 405           do
 406             args[i] = Fread_minibuffer (build_string (prompt), Qnil);
 407           while (! NUMBERP (args[i]));
 408           visargs[i] = last_minibuf_string;
 409           break;
 410
 411         case 'P':               /* Prefix arg in raw form.  Does no I/O.  */
 412         have_prefix_arg:
 413           args[i] = prefix_arg;
 414           /* visargs[i] = Qnil; */
 415           varies[i] = -1;
 416           break;
 417
 418         case 'p':               /* Prefix arg converted to number.  No I/O. */
 419           args[i] = Fprefix_numeric_value (prefix_arg);
 420           /* visargs[i] = Qnil; */
 421           varies[i] = -1;
 422           break;
 423
 424         case 'r':               /* Region, point and mark as 2 args. */
 425           check_mark ();
 426           /* visargs[i+1] = Qnil; */
 427           foo = marker_position (current_buffer->mark);
 428           /* visargs[i] = Qnil; */
 429           XFASTINT (args[i]) = point < foo ? point : foo;
 430           varies[i] = 3;
 431           XFASTINT (args[++i]) = point > foo ? point : foo;
 432           varies[i] = 4;
 433           break;
 434
 435         case 's':               /* String read via minibuffer.  */
 436           args[i] = Fread_string (build_string (prompt), Qnil);
 437           break;
 438
 439         case 'S':               /* Any symbol.  */
 440           visargs[i] = read_minibuf (Vminibuffer_local_ns_map,
 441                                      Qnil,
 442                                      build_string (prompt),
 443                                      0);
 444           /* Passing args[i] directly stimulates compiler bug */
 445           teml = visargs[i];
 446           args[i] = Fintern (teml, Qnil);
 447           break;
 448
 449         case 'v':               /* Variable name: symbol that is
 450                                    user-variable-p. */
 451           args[i] = Fread_variable (build_string (prompt));
 452           visargs[i] = last_minibuf_string;
 453           break;
 454
 455         case 'x':               /* Lisp expression read but not evaluated */
 456           args[i] = Fread_minibuffer (build_string (prompt), Qnil);
 457           visargs[i] = last_minibuf_string;
 458           break;
 459
 460         case 'X':               /* Lisp expression read and evaluated */
 461           args[i] = Feval_minibuffer (build_string (prompt), Qnil);
 462           visargs[i] = last_minibuf_string;
 463           break;
 464
 465         default:
 466           error ("Invalid control letter \"%c\" (%03o) in interactive calling string",
 467                  *tem, *tem);
 468         }
 469
 470       if (varies[i] == 0)
 471         arg_from_tty = 1;
 472
 473       if (NILP (visargs[i]) && XTYPE (args[i]) == Lisp_String)
 474         visargs[i] = args[i];
 475
 476       tem = (unsigned char *) index (tem, '\n');
 477       if (tem) tem++;
 478       else tem = (unsigned char *) "";
 479     }
 480
 481   QUIT;
 482
 483   args[0] = function;
 484
 485   if (arg_from_tty || !NILP (record))
 486     {
 487       visargs[0] = function;
 488       for (i = 1; i < count + 1; i++)
 489         if (varies[i] > 0)
 490           visargs[i] = Fcons (intern (callint_argfuns[varies[i]]), Qnil);
 491         else
 492           visargs[i] = quotify_arg (args[i]);
 493       Vcommand_history = Fcons (Flist (count + 1, visargs),
 494                                 Vcommand_history);
 495     }
 496
 497   {
 498     Lisp_Object val;
 499     int speccount = specpdl_ptr - specpdl;
 500     specbind (Qcommand_debug_status, Qnil);
 501
 502     val = Ffuncall (count + 1, args);
 503     UNGCPRO;
 504     return unbind_to (speccount, val);
 505   }
 506 }
 507
 508 DEFUN ("prefix-numeric-value", Fprefix_numeric_value, Sprefix_numeric_value,
 509   1, 1, 0,
 510   "Return numeric meaning of raw prefix argument ARG.\n\
 511 A raw prefix argument is what you get from `(interactive \"P\")'.\n\
 512 Its numeric meaning is what you would get from `(interactive \"p\")'.")
 513   (raw)
 514      Lisp_Object raw;
 515 {
 516   Lisp_Object val;
 517
 518   /* Tag val as an integer, so the rest of the assignments
 519      may use XSETINT.  */
 520   XFASTINT (val) = 0;
 521
 522   if (NILP (raw))
 523     XFASTINT (val) = 1;
 524   else if (EQ (val, Qminus))
 525     XSETINT (val, -1);
 526   else if (CONSP (raw))
 527     XSETINT (val, XINT (XCONS (raw)->car));
 528   else if (XTYPE (raw) == Lisp_Int)
 529     val = raw;
 530   else
 531     XFASTINT (val) = 1;
 532
 533   return val;
 534 }
 535
 536 syms_of_callint ()
 537 {
 538   Qminus = intern ("-");
 539   staticpro (&Qminus);
 540
 541   Qcall_interactively = intern ("call-interactively");
 542   staticpro (&Qcall_interactively);
 543
 544   Qcommand_debug_status = intern ("command-debug-status");
 545   staticpro (&Qcommand_debug_status);
 546
 547   DEFVAR_LISP ("prefix-arg", &Vprefix_arg,
 548     "The value of the prefix argument for the next editing command.\n\
 549 It may be a number, or the symbol `-' for just a minus sign as arg,\n\
 550 or a list whose car is a number for just one or more C-U's\n\
 551 or nil if no argument has been specified.\n\
 552 \n\
 553 You cannot examine this variable to find the argument for this command\n\
 554 since it has been set to nil by the time you can look.\n\
 555 Instead, you should use the variable `current-prefix-arg', although\n\
 556 normally commands can get this prefix argument with (interactive \"P\").");
 557   Vprefix_arg = Qnil;
 558
 559   DEFVAR_LISP ("current-prefix-arg", &Vcurrent_prefix_arg,
 560     "The value of the prefix argument for this editing command.\n\
 561 It may be a number, or the symbol `-' for just a minus sign as arg,\n\
 562 or a list whose car is a number for just one or more C-U's\n\
 563 or nil if no argument has been specified.\n\
 564 This is what `(interactive \"P\")' returns.");
 565   Vcurrent_prefix_arg = Qnil;
 566
 567   DEFVAR_LISP ("command-history", &Vcommand_history,
 568     "List of recent commands that read arguments from terminal.\n\
 569 Each command is represented as a form to evaluate.");
 570   Vcommand_history = Qnil;
 571
 572   DEFVAR_LISP ("command-debug-status", &Vcommand_debug_status,
 573     "Debugging status of current interactive command.\n\
 574 Bound each time `call-interactively' is called;\n\
 575 may be set by the debugger as a reminder for itself.");
 576   Vcommand_debug_status = Qnil;
 577
 578   defsubr (&Sinteractive);
 579   defsubr (&Scall_interactively);
 580   defsubr (&Sprefix_numeric_value);
 581 }