src/callint.c

   1 /* Call a Lisp function interactively.
   2    Copyright (C) 1985, 1986 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 "window.h"
  26 #include "mocklisp.h"
  27
  28 extern char *index ();
  29
  30 Lisp_Object Vprefix_arg, Vcurrent_prefix_arg, Qminus;
  31 Lisp_Object Qcall_interactively;
  32 Lisp_Object Vcommand_history;
  33
  34 Lisp_Object Vcommand_debug_status, Qcommand_debug_status;
  35
  36 /* This comment supplies the doc string for interactive,
  37    for make-docfile to see.  We cannot put this in the real DEFUN
  38    due to limits in the Unix cpp.
  39
  40 DEFUN ("interactive", Ffoo, Sfoo, 0, 0, 0,
  41  "Specify a way of parsing arguments for interactive use of a function.\n\
  42 For example, write\n\
  43   (defun foo (arg) \"Doc string\" (interactive \"p\") ...use arg...)\n\
  44 to make ARG be the prefix argument when `foo' is called as a command.\n\
  45 The \"call\" to `interactive' is actually a declaration rather than a function;\n\
  46  it tells `call-interactively' how to read arguments\n\
  47  to pass to the function.\n\
  48 When actually called, `interactive' just returns nil.\n\
  49 \n\
  50 The argument of `interactive' is usually a string containing a code letter\n\
  51  followed by a prompt.  (Some code letters do not use I/O to get\n\
  52  the argument and do not need prompts.)  To prompt for multiple arguments,\n\
  53  give a code letter, its prompt, a newline, and another code letter, etc.\n\
  54  Prompts are passed to format, and may use % escapes to print the\n\
  55  arguments that have already been read.\n\
  56 If the argument is not a string, it is evaluated to get a list of\n\
  57  arguments to pass to the function.\n\
  58 Just `(interactive)' means pass no args when calling interactively.\n\
  59 \nCode letters available are:\n\
  60 a -- Function name: symbol with a function definition.\n\
  61 b -- Name of existing buffer.\n\
  62 B -- Name of buffer, possibly nonexistent.\n\
  63 c -- Character.\n\
  64 C -- Command name: symbol with interactive function definition.\n\
  65 d -- Value of point as number.  Does not do I/O.\n\
  66 D -- Directory name.\n\
  67 f -- Existing file name.\n\
  68 F -- Possibly nonexistent file name.\n\
  69 k -- Key sequence (string).\n\
  70 K -- Mouse click that invoked this command - last-command-char.\n\
  71 m -- Value of mark as number.  Does not do I/O.\n\
  72 n -- Number read using minibuffer.\n\
  73 N -- Prefix arg converted to number, or if none, do like code `n'.\n\
  74 p -- Prefix arg converted to number.  Does not do I/O.\n\
  75 P -- Prefix arg in raw form.  Does not do I/O.\n\
  76 r -- Region: point and mark as 2 numeric args, smallest first.  Does no I/O.\n\
  77 s -- Any string.\n\
  78 S -- Any symbol.\n\
  79 v -- Variable name: symbol that is user-variable-p.\n\
  80 x -- Lisp expression read but not evaluated.\n\
  81 X -- Lisp expression read and evaluated.\n\
  82 In addition, if the string begins with `*'\n\
  83  then an error is signaled if the buffer is read-only.\n\
  84  This happens before reading any arguments.\n\
  85 If the string begins with `@', then the window the mouse is over is selected\n\
  86  before anything else is done.  You may use both `@' and `*';\n\
  87 they are processed in the order that they appear."
  88 */
  89
  90 /* ARGSUSED */
  91 DEFUN ("interactive", Finteractive, Sinteractive, 0, UNEVALLED, 0,
  92   0 /* See immediately above */)
  93   (args)
  94      Lisp_Object args;
  95 {
  96   return Qnil;
  97 }
  98
  99 /* Quotify EXP: if EXP is constant, return it.
 100    If EXP is not constant, return (quote EXP).  */
 101 Lisp_Object
 102 quotify_arg (exp)
 103      register Lisp_Object exp;
 104 {
 105   if (XTYPE (exp) != Lisp_Int && XTYPE (exp) != Lisp_String
 106       && !NILP (exp) && !EQ (exp, Qt))
 107     return Fcons (Qquote, Fcons (exp, Qnil));
 108
 109   return exp;
 110 }
 111
 112 /* Modify EXP by quotifying each element (except the first).  */
 113 Lisp_Object
 114 quotify_args (exp)
 115      Lisp_Object exp;
 116 {
 117   register Lisp_Object tail;
 118   register struct Lisp_Cons *ptr;
 119   for (tail = exp; CONSP (tail); tail = ptr->cdr)
 120     {
 121       ptr = XCONS (tail);
 122       ptr->car = quotify_arg (ptr->car);
 123     }
 124   return exp;
 125 }
 126
 127 char *callint_argfuns[]
 128     = {"", "point", "mark", "region-beginning", "region-end"};
 129
 130 static void
 131 check_mark ()
 132 {
 133   Lisp_Object tem = Fmarker_buffer (current_buffer->mark);
 134   if (NILP (tem) || (XBUFFER (tem) != current_buffer))
 135     error ("The mark is not set now");
 136 }
 137
 138
 139 DEFUN ("call-interactively", Fcall_interactively, Scall_interactively, 1, 2, 0,
 140   "Call FUNCTION, reading args according to its interactive calling specs.\n\
 141 The function contains a specification of how to do the argument reading.\n\
 142 In the case of user-defined functions, this is specified by placing a call\n\
 143 to the function `interactive' at the top level of the function body.\n\
 144 See `interactive'.\n\
 145 \n\
 146 Optional second arg RECORD-FLAG non-nil\n\
 147 means unconditionally put this command in the command-history.\n\
 148 Otherwise, this is done only if an arg is read using the minibuffer.")
 149   (function, record)
 150      Lisp_Object function, record;
 151 {
 152   Lisp_Object *args, *visargs;
 153   unsigned char **argstrings;
 154   Lisp_Object fun;
 155   Lisp_Object funcar;
 156   Lisp_Object specs;
 157   Lisp_Object teml;
 158
 159   Lisp_Object prefix_arg;
 160   unsigned char *string;
 161   unsigned char *tem;
 162
 163   /* If varies[i] > 0, the i'th argument shouldn't just have its value
 164      in this call quoted in the command history.  It should be
 165      recorded as a call to the function named callint_argfuns[varies[i]].  */
 166   int *varies;
 167
 168   register int i, j;
 169   int count, foo;
 170   char prompt[100];
 171   char prompt1[100];
 172   char *tem1;
 173   int arg_from_tty = 0;
 174   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 175
 176   /* Save this now, since use ofminibuffer will clobber it. */
 177   prefix_arg = Vcurrent_prefix_arg;
 178
 179 retry:
 180
 181   for (fun = function;
 182        XTYPE (fun) == Lisp_Symbol && !EQ (fun, Qunbound);
 183        fun = XSYMBOL (fun)->function)
 184     ;
 185
 186   specs = Qnil;
 187   string = 0;
 188
 189   /* Decode the kind of function.  Either handle it and return,
 190      or go to `lose' if not interactive, or go to `retry'
 191      to specify a different function, or set either STRING or SPECS.  */
 192
 193   if (XTYPE (fun) == Lisp_Subr)
 194     {
 195       string = (unsigned char *) XSUBR (fun)->prompt;
 196       if (!string)
 197         {
 198         lose:
 199           function = wrong_type_argument (Qcommandp, function, 0);
 200           goto retry;
 201         }
 202       if ((int) string == 1)
 203         /* Let SPECS (which is nil) be used as the args.  */
 204         string = 0;
 205     }
 206   else if (XTYPE (fun) == Lisp_Compiled)
 207     {
 208       if (XVECTOR (fun)->size <= COMPILED_INTERACTIVE)
 209         goto lose;
 210       specs = XVECTOR (fun)->contents[COMPILED_INTERACTIVE];
 211     }
 212   else if (!CONSP (fun))
 213     goto lose;
 214   else if (funcar = Fcar (fun), EQ (funcar, Qautoload))
 215     {
 216       GCPRO2 (function, prefix_arg);
 217       do_autoload (fun, function);
 218       UNGCPRO;
 219       goto retry;
 220     }
 221   else if (EQ (funcar, Qlambda))
 222     {
 223       specs = Fassq (Qinteractive, Fcdr (Fcdr (fun)));
 224       if (NILP (specs))
 225         goto lose;
 226       specs = Fcar (Fcdr (specs));
 227     }
 228   else if (EQ (funcar, Qmocklisp))
 229     return ml_apply (fun, Qinteractive);
 230   else
 231     goto lose;
 232
 233   if (XTYPE (specs) == Lisp_String)
 234     string = XSTRING (specs)->data;
 235   else if (string == 0)
 236     {
 237       i = num_input_chars;
 238       specs = Feval (specs);
 239       if (i != num_input_chars || !NILP (record))
 240         Vcommand_history
 241           = Fcons (Fcons (function, quotify_args (Fcopy_sequence (specs))),
 242                    Vcommand_history);
 243       return apply1 (function, specs);
 244     }
 245
 246   /* Here if function specifies a string to control parsing the defaults */
 247
 248   /* Handle special starting chars `*' and `@'.  */
 249   while (1)
 250     {
 251       if (*string == '*')
 252         {
 253           string++;
 254           if (!NILP (current_buffer->read_only))
 255             Fbarf_if_buffer_read_only ();
 256         }
 257       else if (*string == '@')
 258         {
 259           string++;
 260           if (!NILP (Vmouse_window))
 261             Fselect_window (Vmouse_window);
 262         }
 263       else break;
 264     }
 265
 266   /* Count the number of arguments the interactive spec would have
 267      us give to the function.  */
 268   tem = string;
 269   for (j = 0; *tem; j++)
 270     {
 271       /* 'r' specifications ("point and mark as 2 numeric args")
 272          produce *two* arguments.  */
 273       if (*tem == 'r') j++;
 274       tem = (unsigned char *) index (tem, '\n');
 275       if (tem)
 276         tem++;
 277       else
 278         tem = (unsigned char *) "";
 279     }
 280   count = j;
 281
 282   args = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
 283   visargs = (Lisp_Object *) alloca ((count + 1) * sizeof (Lisp_Object));
 284   argstrings = (unsigned char **) alloca ((count + 1) * sizeof (char *));
 285   varies = (int *) alloca ((count + 1) * sizeof (int));
 286
 287   for (i = 0; i < (count + 1); i++)
 288     {
 289       args[i] = Qnil;
 290       visargs[i] = Qnil;
 291       varies[i] = 0;
 292     }
 293
 294   GCPRO4 (prefix_arg, function, *args, *visargs);
 295   gcpro3.nvars = (count + 1);
 296   gcpro4.nvars = (count + 1);
 297
 298   tem = string;
 299    for (i = 1; *tem; i++)
 300     {
 301       strncpy (prompt1, tem + 1, sizeof prompt1 - 1);
 302       prompt1[sizeof prompt1 - 1] = 0;
 303       tem1 = index (prompt1, '\n');
 304       if (tem1) *tem1 = 0;
 305       /* Fill argstrings with a vector of C strings
 306          corresponding to the Lisp strings in visargs.  */
 307       for (j = 1; j < i; j++)
 308         argstrings[j]
 309           = EQ (visargs[j], Qnil)
 310             ? (unsigned char *) ""
 311             : XSTRING (visargs[j])->data;
 312
 313       doprnt (prompt, sizeof prompt, prompt1, 0, j - 1, argstrings + 1);
 314
 315       switch (*tem)
 316         {
 317         case 'a':               /* Symbol defined as a function */
 318           visargs[i] = Fcompleting_read (build_string (prompt),
 319                                          Vobarray, Qfboundp, Qt, Qnil, Qnil);
 320           /* Passing args[i] directly stimulates compiler bug */
 321           teml = visargs[i];
 322           args[i] = Fintern (teml, Qnil);
 323           break;
 324
 325         case 'b':               /* Name of existing buffer */
 326           args[i] = Fcurrent_buffer ();
 327           if (EQ (selected_window, minibuf_window))
 328             args[i] = Fother_buffer (args[i]);
 329           args[i] = Fread_buffer (build_string (prompt), args[i], Qt);
 330           break;
 331
 332         case 'B':               /* Name of buffer, possibly nonexistent */
 333           args[i] = Fread_buffer (build_string (prompt),
 334                                   Fother_buffer (Fcurrent_buffer ()), Qnil);
 335           break;
 336
 337         case 'c':               /* Character */
 338           message1 (prompt);
 339           args[i] = Fread_char ();
 340           /* Passing args[i] directly stimulates compiler bug */
 341           teml = args[i];
 342           visargs[i] = Fchar_to_string (teml);
 343           break;
 344
 345         case 'C':               /* Command: symbol with interactive function */
 346           visargs[i] = Fcompleting_read (build_string (prompt),
 347                                          Vobarray, Qcommandp, Qt, Qnil, Qnil);
 348           /* Passing args[i] directly stimulates compiler bug */
 349           teml = visargs[i];
 350           args[i] = Fintern (teml, Qnil);
 351           break;
 352
 353         case 'd':               /* Value of point.  Does not do I/O.  */
 354           XFASTINT (args[i]) = point;
 355           /* visargs[i] = Qnil; */
 356           varies[i] = 1;
 357           break;
 358
 359         case 'D':               /* Directory name. */
 360           args[i] = Fread_file_name (build_string (prompt), Qnil,
 361                                      current_buffer->directory, Qlambda, Qnil);
 362           break;
 363
 364         case 'f':               /* Existing file name. */
 365           args[i] = Fread_file_name (build_string (prompt),
 366                                      Qnil, Qnil, Qlambda, Qnil);
 367           break;
 368
 369         case 'F':               /* Possibly nonexistent file name. */
 370           args[i] = Fread_file_name (build_string (prompt),
 371                                      Qnil, Qnil, Qnil, Qnil);
 372           break;
 373
 374         case 'k':               /* Key sequence (string) */
 375           args[i] = Fread_key_sequence (build_string (prompt), Qnil);
 376           teml = args[i];
 377           visargs[i] = Fkey_description (teml);
 378           break;
 379
 380         case 'K':               /* Mouse click.  */
 381           args[i] = last_command_char;
 382           if (NILP (Fmouse_click_p (args[i])))
 383             error ("%s must be bound to a mouse click.",
 384                    (XTYPE (function) == Lisp_Symbol
 385                     ? (char *) XSYMBOL (function)->name->data
 386                     : "Command"));
 387           break;
 388
 389         case 'm':               /* Value of mark.  Does not do I/O.  */
 390           check_mark ();
 391           /* visargs[i] = Qnil; */
 392           XFASTINT (args[i]) = marker_position (current_buffer->mark);
 393           varies[i] = 2;
 394           break;
 395
 396         case 'N':               /* Prefix arg, else number from minibuffer */
 397           if (!NILP (prefix_arg))
 398             goto have_prefix_arg;
 399         case 'n':               /* Read number from minibuffer.  */
 400           do
 401             args[i] = Fread_minibuffer (build_string (prompt), Qnil);
 402 #ifdef LISP_FLOAT_TYPE
 403           while (XTYPE (args[i]) != Lisp_Int
 404                  && XTYPE (args[i]) != Lisp_Float);
 405 #else
 406           while (XTYPE (args[i]) != Lisp_Int);
 407 #endif
 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 (XTYPE (raw) == Lisp_Symbol)
 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 }