root/src/eval.c

DEFINITIONS

1. backtrace_p
2. specpdl_kind
3. specpdl_old_value
4. set_specpdl_old_value
5. specpdl_where
6. specpdl_arg
7. backtrace_function
8. backtrace_nargs
9. backtrace_args
10. set_backtrace_args
11. set_backtrace_debug_on_exit
12. backtrace_p
13. backtrace_thread_p
14. backtrace_top
15. backtrace_thread_top
16. backtrace_next
17. backtrace_thread_next
18. init_eval_once
19. init_eval_once_for_pdumper
20. init_eval
21. max_ensure_room
22. restore_stack_limits
23. call_debugger
24. do_debug_on_call
25. DEFUN
26. DEFUN
27. DEFUN
28. DEFUN
29. DEFUN
30. prog_ignore
31. DEFUN
32. DEFUN
33. DEFUN
34. DEFUN
35. default_toplevel_binding
36. lexbound_p
37. DEFUN
38. defvar
39. DEFUN
40. DEFUN
41. DEFUN
42. DEFUN
43. DEFUN
44. DEFUN
45. with_delayed_message_display
46. with_delayed_message_cancel
47. DEFUN
48. internal_catch
49. unwind_to_catch
50. DEFUN
51. DEFUN
52. internal_lisp_condition_case
53. internal_condition_case
54. internal_condition_case_1
55. internal_condition_case_2
56. internal_condition_case_n
57. internal_catch_all
58. push_handler
59. push_handler_nosignal
60. process_quit_flag
61. probably_quit
62. quit
63. signal_or_quit
64. xsignal0
65. xsignal1
66. xsignal2
67. xsignal3
68. signal_error
69. define_error
70. overflow_error
71. wants_debugger
72. skip_debugger
73. signal_quit_p
74. maybe_call_debugger
75. find_handler_clause
76. vformat_string
77. verror
78. error
79. un_autoload
80. grow_specpdl_allocation
81. eval_sub
82. funcall_nil
83. funcall_not
84. run_hook_wrapped_funcall
85. run_hook_with_args
86. run_hook
87. run_hook_with_args_2
88. apply1
89. DEFUN
90. FUNCTIONP
91. funcall_general
92. funcall_subr
93. fetch_and_exec_byte_code
94. apply_lambda
95. funcall_lambda
96. DEFUN
97. lambda_arity
98. DEFUN
99. let_shadows_buffer_binding_p
100. do_specbind
101. specbind
102. record_unwind_protect
103. record_unwind_protect_array
104. record_unwind_protect_ptr
105. record_unwind_protect_ptr_mark
106. record_unwind_protect_int
107. record_unwind_protect_intmax
108. record_unwind_protect_excursion
109. record_unwind_protect_void
110. record_unwind_protect_module
111. do_one_unbind
112. do_nothing
113. record_unwind_protect_nothing
114. clear_unwind_protect
115. set_unwind_protect
116. set_unwind_protect_ptr
117. unbind_to
118. DEFUN
119. get_backtrace_starting_at
120. get_backtrace_frame
121. backtrace_frame_apply
122. DEFUN
123. specpdl_unrewind
124. backtrace_eval_unrewind
125. mark_specpdl
126. get_backtrace
127. backtrace_top_function
128. syms_of_eval

     1 /* Evaluator for GNU Emacs Lisp interpreter.
     2 
     3 Copyright (C) 1985-1987, 1993-1995, 1999-2023 Free Software Foundation,
     4 Inc.
     5 
     6 This file is part of GNU Emacs.
     7 
     8 GNU Emacs is free software: you can redistribute it and/or modify
     9 it under the terms of the GNU General Public License as published by
    10 the Free Software Foundation, either version 3 of the License, or (at
    11 your option) any later version.
    12 
    13 GNU Emacs is distributed in the hope that it will be useful,
    14 but WITHOUT ANY WARRANTY; without even the implied warranty of
    15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    16 GNU General Public License for more details.
    17 
    18 You should have received a copy of the GNU General Public License
    19 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    20 
    21 
    22 #include <config.h>
    23 #include <limits.h>
    24 #include <stdlib.h>
    25 #include "lisp.h"
    26 #include "blockinput.h"
    27 #include "commands.h"
    28 #include "keyboard.h"
    29 #include "dispextern.h"
    30 #include "buffer.h"
    31 #include "pdumper.h"
    32 #include "atimer.h"
    33 
    34 /* CACHEABLE is ordinarily nothing, except it is 'volatile' if
    35    necessary to cajole GCC into not warning incorrectly that a
    36    variable should be volatile.  */
    37 #if defined GCC_LINT || defined lint
    38 # define CACHEABLE volatile
    39 #else
    40 # define CACHEABLE /* empty */
    41 #endif
    42 
    43 /* Non-nil means record all fset's and provide's, to be undone
    44    if the file being autoloaded is not fully loaded.
    45    They are recorded by being consed onto the front of Vautoload_queue:
    46    (FUN . ODEF) for a defun, (0 . OFEATURES) for a provide.  */
    47 
    48 Lisp_Object Vautoload_queue;
    49 
    50 /* This holds either the symbol `run-hooks' or nil.
    51    It is nil at an early stage of startup, and when Emacs
    52    is shutting down.  */
    53 Lisp_Object Vrun_hooks;
    54 
    55 /* The function from which the last `signal' was called.  Set in
    56    Fsignal.  */
    57 /* FIXME: We should probably get rid of this!  */
    58 Lisp_Object Vsignaling_function;
    59 
    60 /* The handler structure which will catch errors in Lisp hooks called
    61    from redisplay.  We do not use it for this; we compare it with the
    62    handler which is about to be used in signal_or_quit, and if it
    63    matches, cause a backtrace to be generated.  */
    64 static struct handler *redisplay_deep_handler;
    65 
    66 /* These would ordinarily be static, but they need to be visible to GDB.  */
    67 bool backtrace_p (union specbinding *) EXTERNALLY_VISIBLE;
    68 Lisp_Object *backtrace_args (union specbinding *) EXTERNALLY_VISIBLE;
    69 Lisp_Object backtrace_function (union specbinding *) EXTERNALLY_VISIBLE;
    70 union specbinding *backtrace_next (union specbinding *) EXTERNALLY_VISIBLE;
    71 union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE;
    72 
    73 static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *);
    74 static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, specpdl_ref);
    75 static Lisp_Object lambda_arity (Lisp_Object);
    76 
    77 static Lisp_Object
    78 specpdl_symbol (union specbinding *pdl)
    79 {
    80   eassert (pdl->kind >= SPECPDL_LET);
    81   return pdl->let.symbol;
    82 }
    83 
    84 static enum specbind_tag
    85 specpdl_kind (union specbinding *pdl)
    86 {
    87   eassert (pdl->kind >= SPECPDL_LET);
    88   return pdl->let.kind;
    89 }
    90 
    91 static Lisp_Object
    92 specpdl_old_value (union specbinding *pdl)
    93 {
    94   eassert (pdl->kind >= SPECPDL_LET);
    95   return pdl->let.old_value;
    96 }
    97 
    98 static void
    99 set_specpdl_old_value (union specbinding *pdl, Lisp_Object val)
   100 {
   101   eassert (pdl->kind >= SPECPDL_LET);
   102   pdl->let.old_value = val;
   103 }
   104 
   105 static Lisp_Object
   106 specpdl_where (union specbinding *pdl)
   107 {
   108   eassert (pdl->kind > SPECPDL_LET);
   109   return pdl->let.where;
   110 }
   111 
   112 static Lisp_Object
   113 specpdl_arg (union specbinding *pdl)
   114 {
   115   eassert (pdl->kind == SPECPDL_UNWIND);
   116   return pdl->unwind.arg;
   117 }
   118 
   119 Lisp_Object
   120 backtrace_function (union specbinding *pdl)
   121 {
   122   eassert (pdl->kind == SPECPDL_BACKTRACE);
   123   return pdl->bt.function;
   124 }
   125 
   126 static ptrdiff_t
   127 backtrace_nargs (union specbinding *pdl)
   128 {
   129   eassert (pdl->kind == SPECPDL_BACKTRACE);
   130   return pdl->bt.nargs;
   131 }
   132 
   133 Lisp_Object *
   134 backtrace_args (union specbinding *pdl)
   135 {
   136   eassert (pdl->kind == SPECPDL_BACKTRACE);
   137   return pdl->bt.args;
   138 }
   139 
   140 /* Functions to modify slots of backtrace records.  */
   141 
   142 static void
   143 set_backtrace_args (union specbinding *pdl, Lisp_Object *args, ptrdiff_t nargs)
   144 {
   145   eassert (pdl->kind == SPECPDL_BACKTRACE);
   146   pdl->bt.args = args;
   147   pdl->bt.nargs = nargs;
   148 }
   149 
   150 static void
   151 set_backtrace_debug_on_exit (union specbinding *pdl, bool doe)
   152 {
   153   eassert (pdl->kind == SPECPDL_BACKTRACE);
   154   pdl->bt.debug_on_exit = doe;
   155 }
   156 
   157 /* Helper functions to scan the backtrace.  */
   158 
   159 bool
   160 backtrace_p (union specbinding *pdl)
   161 { return specpdl ? pdl >= specpdl : false; }
   162 
   163 static bool
   164 backtrace_thread_p (struct thread_state *tstate, union specbinding *pdl)
   165 { return pdl >= tstate->m_specpdl; }
   166 
   167 union specbinding *
   168 backtrace_top (void)
   169 {
   170   /* This is so "xbacktrace" doesn't crash in pdumped Emacs if they
   171      invoke the command before init_eval_once_for_pdumper initializes
   172      specpdl machinery.  See also backtrace_p above.  */
   173   if (!specpdl)
   174     return NULL;
   175 
   176   union specbinding *pdl = specpdl_ptr - 1;
   177   while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
   178     pdl--;
   179   return pdl;
   180 }
   181 
   182 static union specbinding *
   183 backtrace_thread_top (struct thread_state *tstate)
   184 {
   185   union specbinding *pdl = tstate->m_specpdl_ptr - 1;
   186   while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
   187     pdl--;
   188   return pdl;
   189 }
   190 
   191 union specbinding *
   192 backtrace_next (union specbinding *pdl)
   193 {
   194   pdl--;
   195   while (backtrace_p (pdl) && pdl->kind != SPECPDL_BACKTRACE)
   196     pdl--;
   197   return pdl;
   198 }
   199 
   200 static void init_eval_once_for_pdumper (void);
   201 
   202 static union specbinding *
   203 backtrace_thread_next (struct thread_state *tstate, union specbinding *pdl)
   204 {
   205   pdl--;
   206   while (backtrace_thread_p (tstate, pdl) && pdl->kind != SPECPDL_BACKTRACE)
   207     pdl--;
   208   return pdl;
   209 }
   210 
   211 void
   212 init_eval_once (void)
   213 {
   214   /* Don't forget to update docs (lispref node "Eval").  */
   215   max_lisp_eval_depth = 1600;
   216   Vrun_hooks = Qnil;
   217   pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
   218 }
   219 
   220 static void
   221 init_eval_once_for_pdumper (void)
   222 {
   223   enum { size = 50 };
   224   union specbinding *pdlvec = malloc ((size + 1) * sizeof *specpdl);
   225   specpdl = specpdl_ptr = pdlvec + 1;
   226   specpdl_end = specpdl + size;
   227 }
   228 
   229 void
   230 init_eval (void)
   231 {
   232   specpdl_ptr = specpdl;
   233   { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
   234        This is important since handlerlist->nextfree holds the freelist
   235        which would otherwise leak every time we unwind back to top-level.   */
   236     handlerlist_sentinel = xzalloc (sizeof (struct handler));
   237     handlerlist = handlerlist_sentinel->nextfree = handlerlist_sentinel;
   238     struct handler *c = push_handler (Qunbound, CATCHER);
   239     eassert (c == handlerlist_sentinel);
   240     handlerlist_sentinel->nextfree = NULL;
   241     handlerlist_sentinel->next = NULL;
   242   }
   243   Vquit_flag = Qnil;
   244   debug_on_next_call = 0;
   245   lisp_eval_depth = 0;
   246   /* This is less than the initial value of num_nonmacro_input_events.  */
   247   when_entered_debugger = -1;
   248   redisplay_deep_handler = NULL;
   249 }
   250 
   251 /* Ensure that *M is at least A + B if possible, or is its maximum
   252    value otherwise.  */
   253 
   254 static void
   255 max_ensure_room (intmax_t *m, intmax_t a, intmax_t b)
   256 {
   257   intmax_t sum = ckd_add (&sum, a, b) ? INTMAX_MAX : sum;
   258   *m = max (*m, sum);
   259 }
   260 
   261 /* Unwind-protect function used by call_debugger.  */
   262 
   263 static void
   264 restore_stack_limits (Lisp_Object data)
   265 {
   266   integer_to_intmax (data, &max_lisp_eval_depth);
   267 }
   268 
   269 /* Call the Lisp debugger, giving it argument ARG.  */
   270 
   271 Lisp_Object
   272 call_debugger (Lisp_Object arg)
   273 {
   274   bool debug_while_redisplaying;
   275   specpdl_ref count = SPECPDL_INDEX ();
   276   Lisp_Object val;
   277   intmax_t old_depth = max_lisp_eval_depth;
   278 
   279   /* The previous value of 40 is too small now that the debugger
   280      prints using cl-prin1 instead of prin1.  Printing lists nested 8
   281      deep (which is the value of print-level used in the debugger)
   282      currently requires 77 additional frames.  See bug#31919.  */
   283   max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
   284 
   285   /* Restore limits after leaving the debugger.  */
   286   record_unwind_protect (restore_stack_limits, make_int (old_depth));
   287 
   288 #ifdef HAVE_WINDOW_SYSTEM
   289   if (display_hourglass_p)
   290     cancel_hourglass ();
   291 #endif
   292 
   293   debug_on_next_call = 0;
   294   when_entered_debugger = num_nonmacro_input_events;
   295 
   296   /* Resetting redisplaying_p to 0 makes sure that debug output is
   297      displayed if the debugger is invoked during redisplay.  */
   298   debug_while_redisplaying = redisplaying_p;
   299   redisplaying_p = 0;
   300   specbind (intern ("debugger-may-continue"),
   301             debug_while_redisplaying ? Qnil : Qt);
   302   specbind (Qinhibit_redisplay, Qnil);
   303   specbind (Qinhibit_debugger, Qt);
   304 
   305   /* If we are debugging an error while `inhibit-changing-match-data'
   306      is bound to non-nil (e.g., within a call to `string-match-p'),
   307      then make sure debugger code can still use match data.  */
   308   specbind (Qinhibit_changing_match_data, Qnil);
   309 
   310 #if 0 /* Binding this prevents execution of Lisp code during
   311          redisplay, which necessarily leads to display problems.  */
   312   specbind (Qinhibit_eval_during_redisplay, Qt);
   313 #endif
   314 
   315   val = apply1 (Vdebugger, arg);
   316 
   317   /* Interrupting redisplay and resuming it later is not safe under
   318      all circumstances.  So, when the debugger returns, abort the
   319      interrupted redisplay by going back to the top-level.  */
   320   if (debug_while_redisplaying
   321       && !EQ (Vdebugger, Qdebug_early))
   322     Ftop_level ();
   323 
   324   return unbind_to (count, val);
   325 }
   326 
   327 void
   328 do_debug_on_call (Lisp_Object code, specpdl_ref count)
   329 {
   330   debug_on_next_call = 0;
   331   set_backtrace_debug_on_exit (specpdl_ref_to_ptr (count), true);
   332   call_debugger (list1 (code));
   333 }
   334 
   335 
   336 DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
   337        doc: /* Eval args until one of them yields non-nil, then return that value.
   338 The remaining args are not evalled at all.
   339 If all args return nil, return nil.
   340 usage: (or CONDITIONS...)  */)
   341   (Lisp_Object args)
   342 {
   343   Lisp_Object val = Qnil;
   344 
   345   while (CONSP (args))
   346     {
   347       Lisp_Object arg = XCAR (args);
   348       args = XCDR (args);
   349       val = eval_sub (arg);
   350       if (!NILP (val))
   351         break;
   352     }
   353 
   354   return val;
   355 }
   356 
   357 DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
   358        doc: /* Eval args until one of them yields nil, then return nil.
   359 The remaining args are not evalled at all.
   360 If no arg yields nil, return the last arg's value.
   361 usage: (and CONDITIONS...)  */)
   362   (Lisp_Object args)
   363 {
   364   Lisp_Object val = Qt;
   365 
   366   while (CONSP (args))
   367     {
   368       Lisp_Object arg = XCAR (args);
   369       args = XCDR (args);
   370       val = eval_sub (arg);
   371       if (NILP (val))
   372         break;
   373     }
   374 
   375   return val;
   376 }
   377 
   378 DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
   379        doc: /* If COND yields non-nil, do THEN, else do ELSE...
   380 Returns the value of THEN or the value of the last of the ELSE's.
   381 THEN must be one expression, but ELSE... can be zero or more expressions.
   382 If COND yields nil, and there are no ELSE's, the value is nil.
   383 usage: (if COND THEN ELSE...)  */)
   384   (Lisp_Object args)
   385 {
   386   Lisp_Object cond;
   387 
   388   cond = eval_sub (XCAR (args));
   389 
   390   if (!NILP (cond))
   391     return eval_sub (Fcar (XCDR (args)));
   392   return Fprogn (Fcdr (XCDR (args)));
   393 }
   394 
   395 DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
   396        doc: /* Try each clause until one succeeds.
   397 Each clause looks like (CONDITION BODY...).  CONDITION is evaluated
   398 and, if the value is non-nil, this clause succeeds:
   399 then the expressions in BODY are evaluated and the last one's
   400 value is the value of the cond-form.
   401 If a clause has one element, as in (CONDITION), then the cond-form
   402 returns CONDITION's value, if that is non-nil.
   403 If no clause succeeds, cond returns nil.
   404 usage: (cond CLAUSES...)  */)
   405   (Lisp_Object args)
   406 {
   407   Lisp_Object val = args;
   408 
   409   while (CONSP (args))
   410     {
   411       Lisp_Object clause = XCAR (args);
   412       val = eval_sub (Fcar (clause));
   413       if (!NILP (val))
   414         {
   415           if (!NILP (XCDR (clause)))
   416             val = Fprogn (XCDR (clause));
   417           break;
   418         }
   419       args = XCDR (args);
   420     }
   421 
   422   return val;
   423 }
   424 
   425 DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
   426        doc: /* Eval BODY forms sequentially and return value of last one.
   427 usage: (progn BODY...)  */)
   428   (Lisp_Object body)
   429 {
   430   Lisp_Object CACHEABLE val = Qnil;
   431 
   432   while (CONSP (body))
   433     {
   434       Lisp_Object form = XCAR (body);
   435       body = XCDR (body);
   436       val = eval_sub (form);
   437     }
   438 
   439   return val;
   440 }
   441 
   442 /* Evaluate BODY sequentially, discarding its value.  */
   443 
   444 void
   445 prog_ignore (Lisp_Object body)
   446 {
   447   Fprogn (body);
   448 }
   449 
   450 DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
   451        doc: /* Eval FIRST and BODY sequentially; return value from FIRST.
   452 The value of FIRST is saved during the evaluation of the remaining args,
   453 whose values are discarded.
   454 usage: (prog1 FIRST BODY...)  */)
   455   (Lisp_Object args)
   456 {
   457   Lisp_Object val = eval_sub (XCAR (args));
   458   prog_ignore (XCDR (args));
   459   return val;
   460 }
   461 
   462 DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
   463        doc: /* Set each SYM to the value of its VAL.
   464 The symbols SYM are variables; they are literal (not evaluated).
   465 The values VAL are expressions; they are evaluated.
   466 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
   467 The second VAL is not computed until after the first SYM is set, and so on;
   468 each VAL can use the new value of variables set earlier in the `setq'.
   469 The return value of the `setq' form is the value of the last VAL.
   470 usage: (setq [SYM VAL]...)  */)
   471   (Lisp_Object args)
   472 {
   473   Lisp_Object val = args, tail = args;
   474 
   475   for (EMACS_INT nargs = 0; CONSP (tail); nargs += 2)
   476     {
   477       Lisp_Object sym = XCAR (tail);
   478       tail = XCDR (tail);
   479       if (!CONSP (tail))
   480         xsignal2 (Qwrong_number_of_arguments, Qsetq, make_fixnum (nargs + 1));
   481       Lisp_Object arg = XCAR (tail);
   482       tail = XCDR (tail);
   483       val = eval_sub (arg);
   484       /* Like for eval_sub, we do not check declared_special here since
   485          it's been done when let-binding.  */
   486       Lisp_Object lex_binding
   487         = (SYMBOLP (sym)
   488            ? Fassq (sym, Vinternal_interpreter_environment)
   489            : Qnil);
   490       if (!NILP (lex_binding))
   491         XSETCDR (lex_binding, val); /* SYM is lexically bound.  */
   492       else
   493         Fset (sym, val);        /* SYM is dynamically bound.  */
   494     }
   495 
   496   return val;
   497 }
   498 
   499 DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
   500        doc: /* Return the argument, without evaluating it.  `(quote x)' yields `x'.
   501 Warning: `quote' does not construct its return value, but just returns
   502 the value that was pre-constructed by the Lisp reader (see info node
   503 `(elisp)Printed Representation').
   504 This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
   505 does not cons.  Quoting should be reserved for constants that will
   506 never be modified by side-effects, unless you like self-modifying code.
   507 See the common pitfall in info node `(elisp)Rearrangement' for an example
   508 of unexpected results when a quoted object is modified.
   509 usage: (quote ARG)  */)
   510   (Lisp_Object args)
   511 {
   512   if (!NILP (XCDR (args)))
   513     xsignal2 (Qwrong_number_of_arguments, Qquote, Flength (args));
   514   return XCAR (args);
   515 }
   516 
   517 DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
   518        doc: /* Like `quote', but preferred for objects which are functions.
   519 In byte compilation, `function' causes its argument to be handled by
   520 the byte compiler.  Similarly, when expanding macros and expressions,
   521 ARG can be examined and possibly expanded.  If `quote' is used
   522 instead, this doesn't happen.
   523 
   524 usage: (function ARG)  */)
   525   (Lisp_Object args)
   526 {
   527   Lisp_Object quoted = XCAR (args);
   528 
   529   if (!NILP (XCDR (args)))
   530     xsignal2 (Qwrong_number_of_arguments, Qfunction, Flength (args));
   531 
   532   if (!NILP (Vinternal_interpreter_environment)
   533       && CONSP (quoted)
   534       && EQ (XCAR (quoted), Qlambda))
   535     { /* This is a lambda expression within a lexical environment;
   536          return an interpreted closure instead of a simple lambda.  */
   537       Lisp_Object cdr = XCDR (quoted);
   538       Lisp_Object tmp = cdr;
   539       if (CONSP (tmp)
   540           && (tmp = XCDR (tmp), CONSP (tmp))
   541           && (tmp = XCAR (tmp), CONSP (tmp))
   542           && (EQ (QCdocumentation, XCAR (tmp))))
   543         { /* Handle the special (:documentation <form>) to build the docstring
   544              dynamically.  */
   545           Lisp_Object docstring = eval_sub (Fcar (XCDR (tmp)));
   546           if (SYMBOLP (docstring) && !NILP (docstring))
   547             /* Hack for OClosures: Allow the docstring to be a symbol
   548              * (the OClosure's type).  */
   549             docstring = Fsymbol_name (docstring);
   550           CHECK_STRING (docstring);
   551           cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
   552         }
   553       if (NILP (Vinternal_make_interpreted_closure_function))
   554         return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, cdr));
   555       else
   556         return call2 (Vinternal_make_interpreted_closure_function,
   557                       Fcons (Qlambda, cdr),
   558                       Vinternal_interpreter_environment);
   559     }
   560   else
   561     /* Simply quote the argument.  */
   562     return quoted;
   563 }
   564 
   565 
   566 DEFUN ("defvaralias", Fdefvaralias, Sdefvaralias, 2, 3, 0,
   567        doc: /* Make NEW-ALIAS a variable alias for symbol BASE-VARIABLE.
   568 Aliased variables always have the same value; setting one sets the other.
   569 Third arg DOCSTRING, if non-nil, is documentation for NEW-ALIAS.  If it is
   570 omitted or nil, NEW-ALIAS gets the documentation string of BASE-VARIABLE,
   571 or of the variable at the end of the chain of aliases, if BASE-VARIABLE is
   572 itself an alias.  If NEW-ALIAS is bound, and BASE-VARIABLE is not,
   573 then the value of BASE-VARIABLE is set to that of NEW-ALIAS.
   574 The return value is BASE-VARIABLE.
   575 
   576 If the resulting chain of variable definitions would contain a loop,
   577 signal a `cyclic-variable-indirection' error.  */)
   578   (Lisp_Object new_alias, Lisp_Object base_variable, Lisp_Object docstring)
   579 {
   580   CHECK_SYMBOL (new_alias);
   581   CHECK_SYMBOL (base_variable);
   582 
   583   if (SYMBOL_CONSTANT_P (new_alias))
   584     /* Making it an alias effectively changes its value.  */
   585     error ("Cannot make a constant an alias: %s",
   586            SDATA (SYMBOL_NAME (new_alias)));
   587 
   588   struct Lisp_Symbol *sym = XSYMBOL (new_alias);
   589 
   590   /* Ensure non-circularity.  */
   591   struct Lisp_Symbol *s = XSYMBOL (base_variable);
   592   for (;;)
   593     {
   594       if (s == sym)
   595         xsignal1 (Qcyclic_variable_indirection, base_variable);
   596       if (s->u.s.redirect != SYMBOL_VARALIAS)
   597         break;
   598       s = SYMBOL_ALIAS (s);
   599     }
   600 
   601   switch (sym->u.s.redirect)
   602     {
   603     case SYMBOL_FORWARDED:
   604       error ("Cannot make a built-in variable an alias: %s",
   605              SDATA (SYMBOL_NAME (new_alias)));
   606     case SYMBOL_LOCALIZED:
   607       error ("Don't know how to make a buffer-local variable an alias: %s",
   608              SDATA (SYMBOL_NAME (new_alias)));
   609     case SYMBOL_PLAINVAL:
   610     case SYMBOL_VARALIAS:
   611       break;
   612     default:
   613       emacs_abort ();
   614     }
   615 
   616   /* https://lists.gnu.org/r/emacs-devel/2008-04/msg00834.html
   617      If n_a is bound, but b_v is not, set the value of b_v to n_a,
   618      so that old-code that affects n_a before the aliasing is setup
   619      still works.  */
   620   if (NILP (Fboundp (base_variable)))
   621     set_internal (base_variable, find_symbol_value (new_alias),
   622                   Qnil, SET_INTERNAL_BIND);
   623   else if (!NILP (Fboundp (new_alias))
   624            && !EQ (find_symbol_value (new_alias),
   625                    find_symbol_value (base_variable)))
   626     call2 (intern ("display-warning"),
   627            list3 (Qdefvaralias, intern ("losing-value"), new_alias),
   628            CALLN (Fformat_message,
   629                   build_string
   630                   ("Overwriting value of `%s' by aliasing to `%s'"),
   631                   new_alias, base_variable));
   632 
   633   {
   634     union specbinding *p;
   635 
   636     for (p = specpdl_ptr; p > specpdl; )
   637       if ((--p)->kind >= SPECPDL_LET
   638           && (EQ (new_alias, specpdl_symbol (p))))
   639         error ("Don't know how to make a let-bound variable an alias: %s",
   640                SDATA (SYMBOL_NAME (new_alias)));
   641   }
   642 
   643   if (sym->u.s.trapped_write == SYMBOL_TRAPPED_WRITE)
   644     notify_variable_watchers (new_alias, base_variable, Qdefvaralias, Qnil);
   645 
   646   sym->u.s.declared_special = true;
   647   XSYMBOL (base_variable)->u.s.declared_special = true;
   648   sym->u.s.redirect = SYMBOL_VARALIAS;
   649   SET_SYMBOL_ALIAS (sym, XSYMBOL (base_variable));
   650   sym->u.s.trapped_write = XSYMBOL (base_variable)->u.s.trapped_write;
   651   LOADHIST_ATTACH (new_alias);
   652   /* Even if docstring is nil: remove old docstring.  */
   653   Fput (new_alias, Qvariable_documentation, docstring);
   654 
   655   return base_variable;
   656 }
   657 
   658 static union specbinding *
   659 default_toplevel_binding (Lisp_Object symbol)
   660 {
   661   union specbinding *binding = NULL;
   662   union specbinding *pdl = specpdl_ptr;
   663   while (pdl > specpdl)
   664     {
   665       switch ((--pdl)->kind)
   666         {
   667         case SPECPDL_LET_DEFAULT:
   668         case SPECPDL_LET:
   669           if (EQ (specpdl_symbol (pdl), symbol))
   670             binding = pdl;
   671           break;
   672 
   673         default: break;
   674         }
   675     }
   676   return binding;
   677 }
   678 
   679 /* Look for a lexical-binding of SYMBOL somewhere up the stack.
   680    This will only find bindings created with interpreted code, since once
   681    compiled names of lexical variables are basically gone anyway.  */
   682 static bool
   683 lexbound_p (Lisp_Object symbol)
   684 {
   685   union specbinding *pdl = specpdl_ptr;
   686   while (pdl > specpdl)
   687     {
   688       switch ((--pdl)->kind)
   689         {
   690         case SPECPDL_LET_DEFAULT:
   691         case SPECPDL_LET:
   692           if (EQ (specpdl_symbol (pdl), Qinternal_interpreter_environment))
   693             {
   694               Lisp_Object env = specpdl_old_value (pdl);
   695               if (CONSP (env) && !NILP (Fassq (symbol, env)))
   696                 return true;
   697             }
   698           break;
   699 
   700         default: break;
   701         }
   702     }
   703   return false;
   704 }
   705 
   706 DEFUN ("default-toplevel-value", Fdefault_toplevel_value, Sdefault_toplevel_value, 1, 1, 0,
   707        doc: /* Return SYMBOL's toplevel default value.
   708 "Toplevel" means outside of any let binding.  */)
   709   (Lisp_Object symbol)
   710 {
   711   union specbinding *binding = default_toplevel_binding (symbol);
   712   Lisp_Object value
   713     = binding ? specpdl_old_value (binding) : Fdefault_value (symbol);
   714   if (!BASE_EQ (value, Qunbound))
   715     return value;
   716   xsignal1 (Qvoid_variable, symbol);
   717 }
   718 
   719 DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value,
   720        Sset_default_toplevel_value, 2, 2, 0,
   721        doc: /* Set SYMBOL's toplevel default value to VALUE.
   722 "Toplevel" means outside of any let binding.  */)
   723      (Lisp_Object symbol, Lisp_Object value)
   724 {
   725   union specbinding *binding = default_toplevel_binding (symbol);
   726   if (binding)
   727     set_specpdl_old_value (binding, value);
   728   else
   729     Fset_default (symbol, value);
   730   return Qnil;
   731 }
   732 
   733 DEFUN ("internal--define-uninitialized-variable",
   734        Finternal__define_uninitialized_variable,
   735        Sinternal__define_uninitialized_variable, 1, 2, 0,
   736        doc: /* Define SYMBOL as a variable, with DOC as its docstring.
   737 This is like `defvar' and `defconst' but without affecting the variable's
   738 value.  */)
   739   (Lisp_Object symbol, Lisp_Object doc)
   740 {
   741   if (!XSYMBOL (symbol)->u.s.declared_special
   742       && lexbound_p (symbol))
   743     /* This test tries to catch the situation where we do
   744        (let ((<foo-var> ...)) ...(<foo-function> ...)....)
   745        and where the `foo` package only gets loaded when <foo-function>
   746        is called, so the outer `let` incorrectly made the binding lexical
   747        because the <foo-var> wasn't yet declared as dynamic at that point.  */
   748     xsignal2 (Qerror,
   749               build_string ("Defining as dynamic an already lexical var"),
   750               symbol);
   751 
   752   XSYMBOL (symbol)->u.s.declared_special = true;
   753   if (!NILP (doc))
   754     {
   755       if (!NILP (Vpurify_flag))
   756         doc = Fpurecopy (doc);
   757       Fput (symbol, Qvariable_documentation, doc);
   758     }
   759   LOADHIST_ATTACH (symbol);
   760   return Qnil;
   761 }
   762 
   763 static Lisp_Object
   764 defvar (Lisp_Object sym, Lisp_Object initvalue, Lisp_Object docstring, bool eval)
   765 {
   766   Lisp_Object tem;
   767 
   768   CHECK_SYMBOL (sym);
   769 
   770   tem = Fdefault_boundp (sym);
   771 
   772   /* Do it before evaluating the initial value, for self-references.  */
   773   Finternal__define_uninitialized_variable (sym, docstring);
   774 
   775   if (NILP (tem))
   776     Fset_default (sym, eval ? eval_sub (initvalue) : initvalue);
   777   else
   778     { /* Check if there is really a global binding rather than just a let
   779              binding that shadows the global unboundness of the var.  */
   780       union specbinding *binding = default_toplevel_binding (sym);
   781       if (binding && BASE_EQ (specpdl_old_value (binding), Qunbound))
   782         {
   783           set_specpdl_old_value (binding,
   784                                  eval ? eval_sub (initvalue) : initvalue);
   785         }
   786     }
   787   return sym;
   788 }
   789 
   790 DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
   791        doc: /* Define SYMBOL as a variable, and return SYMBOL.
   792 You are not required to define a variable in order to use it, but
   793 defining it lets you supply an initial value and documentation, which
   794 can be referred to by the Emacs help facilities and other programming
   795 tools.  The `defvar' form also declares the variable as \"special\",
   796 so that it is always dynamically bound even if `lexical-binding' is t.
   797 
   798 If SYMBOL's value is void and the optional argument INITVALUE is
   799 provided, INITVALUE is evaluated and the result used to set SYMBOL's
   800 value.  If SYMBOL is buffer-local, its default value is what is set;
   801 buffer-local values are not affected.  If INITVALUE is missing,
   802 SYMBOL's value is not set.
   803 
   804 If SYMBOL is let-bound, then this form does not affect the local let
   805 binding but the toplevel default binding instead, like
   806 `set-toplevel-default-binding`.
   807 (`defcustom' behaves similarly in this respect.)
   808 
   809 The optional argument DOCSTRING is a documentation string for the
   810 variable.
   811 
   812 To define a user option, use `defcustom' instead of `defvar'.
   813 
   814 To define a buffer-local variable, use `defvar-local'.
   815 usage: (defvar SYMBOL &optional INITVALUE DOCSTRING)  */)
   816   (Lisp_Object args)
   817 {
   818   Lisp_Object sym, tail;
   819 
   820   sym = XCAR (args);
   821   tail = XCDR (args);
   822 
   823   CHECK_SYMBOL (sym);
   824 
   825   if (!NILP (tail))
   826     {
   827       if (!NILP (XCDR (tail)) && !NILP (XCDR (XCDR (tail))))
   828         error ("Too many arguments");
   829       Lisp_Object exp = XCAR (tail);
   830       tail = XCDR (tail);
   831       return defvar (sym, exp, CAR (tail), true);
   832     }
   833   else if (!NILP (Vinternal_interpreter_environment)
   834            && (SYMBOLP (sym) && !XSYMBOL (sym)->u.s.declared_special))
   835     /* A simple (defvar foo) with lexical scoping does "nothing" except
   836        declare that var to be dynamically scoped *locally* (i.e. within
   837        the current file or let-block).  */
   838     Vinternal_interpreter_environment
   839       = Fcons (sym, Vinternal_interpreter_environment);
   840   else
   841     {
   842       /* Simple (defvar <var>) should not count as a definition at all.
   843          It could get in the way of other definitions, and unloading this
   844          package could try to make the variable unbound.  */
   845     }
   846 
   847   return sym;
   848 }
   849 
   850 DEFUN ("defvar-1", Fdefvar_1, Sdefvar_1, 2, 3, 0,
   851        doc: /* Like `defvar' but as a function.
   852 More specifically behaves like (defvar SYM 'INITVALUE DOCSTRING).  */)
   853   (Lisp_Object sym, Lisp_Object initvalue, Lisp_Object docstring)
   854 {
   855   return defvar (sym, initvalue, docstring, false);
   856 }
   857 
   858 DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
   859        doc: /* Define SYMBOL as a constant variable.
   860 This declares that neither programs nor users should ever change the
   861 value.  This constancy is not actually enforced by Emacs Lisp, but
   862 SYMBOL is marked as a special variable so that it is never lexically
   863 bound.
   864 
   865 The `defconst' form always sets the value of SYMBOL to the result of
   866 evalling INITVALUE.  If SYMBOL is buffer-local, its default value is
   867 what is set; buffer-local values are not affected.  If SYMBOL has a
   868 local binding, then this form sets the local binding's value.
   869 However, you should normally not make local bindings for variables
   870 defined with this form.
   871 
   872 The optional DOCSTRING specifies the variable's documentation string.
   873 usage: (defconst SYMBOL INITVALUE [DOCSTRING])  */)
   874   (Lisp_Object args)
   875 {
   876   Lisp_Object sym, tem;
   877 
   878   sym = XCAR (args);
   879   CHECK_SYMBOL (sym);
   880   Lisp_Object docstring = Qnil;
   881   if (!NILP (XCDR (XCDR (args))))
   882     {
   883       if (!NILP (XCDR (XCDR (XCDR (args)))))
   884         error ("Too many arguments");
   885       docstring = XCAR (XCDR (XCDR (args)));
   886     }
   887   tem = eval_sub (XCAR (XCDR (args)));
   888   return Fdefconst_1 (sym, tem, docstring);
   889 }
   890 
   891 DEFUN ("defconst-1", Fdefconst_1, Sdefconst_1, 2, 3, 0,
   892        doc: /* Like `defconst' but as a function.
   893 More specifically, behaves like (defconst SYM 'INITVALUE DOCSTRING).  */)
   894   (Lisp_Object sym, Lisp_Object initvalue, Lisp_Object docstring)
   895 {
   896   CHECK_SYMBOL (sym);
   897   Lisp_Object tem = initvalue;
   898   Finternal__define_uninitialized_variable (sym, docstring);
   899   if (!NILP (Vpurify_flag))
   900     tem = Fpurecopy (tem);
   901   Fset_default (sym, tem);      /* FIXME: set-default-toplevel-value? */
   902   Fput (sym, Qrisky_local_variable, Qt); /* FIXME: Why?  */
   903   return sym;
   904 }
   905 
   906 /* Make SYMBOL lexically scoped.  */
   907 DEFUN ("internal-make-var-non-special", Fmake_var_non_special,
   908        Smake_var_non_special, 1, 1, 0,
   909        doc: /* Internal function.  */)
   910      (Lisp_Object symbol)
   911 {
   912   CHECK_SYMBOL (symbol);
   913   XSYMBOL (symbol)->u.s.declared_special = false;
   914   return Qnil;
   915 }
   916 
   917 
   918 DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
   919        doc: /* Bind variables according to VARLIST then eval BODY.
   920 The value of the last form in BODY is returned.
   921 Each element of VARLIST is a symbol (which is bound to nil)
   922 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
   923 Each VALUEFORM can refer to the symbols already bound by this VARLIST.
   924 usage: (let* VARLIST BODY...)  */)
   925   (Lisp_Object args)
   926 {
   927   Lisp_Object var, val, elt, lexenv;
   928   specpdl_ref count = SPECPDL_INDEX ();
   929 
   930   lexenv = Vinternal_interpreter_environment;
   931 
   932   Lisp_Object varlist = XCAR (args);
   933   FOR_EACH_TAIL (varlist)
   934     {
   935       elt = XCAR (varlist);
   936       if (SYMBOLP (elt))
   937         {
   938           var = elt;
   939           val = Qnil;
   940         }
   941       else
   942         {
   943           var = Fcar (elt);
   944           if (! NILP (Fcdr (XCDR (elt))))
   945             signal_error ("`let' bindings can have only one value-form", elt);
   946           val = eval_sub (Fcar (XCDR (elt)));
   947         }
   948 
   949       if (!NILP (lexenv) && SYMBOLP (var)
   950           && !XSYMBOL (var)->u.s.declared_special
   951           && NILP (Fmemq (var, Vinternal_interpreter_environment)))
   952         /* Lexically bind VAR by adding it to the interpreter's binding
   953            alist.  */
   954         {
   955           Lisp_Object newenv
   956             = Fcons (Fcons (var, val), Vinternal_interpreter_environment);
   957           if (EQ (Vinternal_interpreter_environment, lexenv))
   958             /* Save the old lexical environment on the specpdl stack,
   959                but only for the first lexical binding, since we'll never
   960                need to revert to one of the intermediate ones.  */
   961             specbind (Qinternal_interpreter_environment, newenv);
   962           else
   963             Vinternal_interpreter_environment = newenv;
   964         }
   965       else
   966         specbind (var, val);
   967     }
   968   CHECK_LIST_END (varlist, XCAR (args));
   969 
   970   val = Fprogn (XCDR (args));
   971   return unbind_to (count, val);
   972 }
   973 
   974 DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
   975        doc: /* Bind variables according to VARLIST then eval BODY.
   976 The value of the last form in BODY is returned.
   977 Each element of VARLIST is a symbol (which is bound to nil)
   978 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
   979 All the VALUEFORMs are evalled before any symbols are bound.
   980 usage: (let VARLIST BODY...)  */)
   981   (Lisp_Object args)
   982 {
   983   Lisp_Object *temps, tem, lexenv;
   984   Lisp_Object elt;
   985   specpdl_ref count = SPECPDL_INDEX ();
   986   ptrdiff_t argnum;
   987   USE_SAFE_ALLOCA;
   988 
   989   Lisp_Object varlist = XCAR (args);
   990 
   991   /* Make space to hold the values to give the bound variables.  */
   992   EMACS_INT varlist_len = list_length (varlist);
   993   SAFE_ALLOCA_LISP (temps, varlist_len);
   994   ptrdiff_t nvars = varlist_len;
   995 
   996   /* Compute the values and store them in `temps'.  */
   997 
   998   for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++)
   999     {
  1000       maybe_quit ();
  1001       elt = XCAR (varlist);
  1002       varlist = XCDR (varlist);
  1003       if (SYMBOLP (elt))
  1004         temps[argnum] = Qnil;
  1005       else if (! NILP (Fcdr (Fcdr (elt))))
  1006         signal_error ("`let' bindings can have only one value-form", elt);
  1007       else
  1008         temps[argnum] = eval_sub (Fcar (Fcdr (elt)));
  1009     }
  1010   nvars = argnum;
  1011 
  1012   lexenv = Vinternal_interpreter_environment;
  1013 
  1014   varlist = XCAR (args);
  1015   for (argnum = 0; argnum < nvars && CONSP (varlist); argnum++)
  1016     {
  1017       Lisp_Object var;
  1018 
  1019       elt = XCAR (varlist);
  1020       varlist = XCDR (varlist);
  1021       var = SYMBOLP (elt) ? elt : Fcar (elt);
  1022       tem = temps[argnum];
  1023 
  1024       if (!NILP (lexenv) && SYMBOLP (var)
  1025           && !XSYMBOL (var)->u.s.declared_special
  1026           && NILP (Fmemq (var, Vinternal_interpreter_environment)))
  1027         /* Lexically bind VAR by adding it to the lexenv alist.  */
  1028         lexenv = Fcons (Fcons (var, tem), lexenv);
  1029       else
  1030         /* Dynamically bind VAR.  */
  1031         specbind (var, tem);
  1032     }
  1033 
  1034   if (!EQ (lexenv, Vinternal_interpreter_environment))
  1035     /* Instantiate a new lexical environment.  */
  1036     specbind (Qinternal_interpreter_environment, lexenv);
  1037 
  1038   elt = Fprogn (XCDR (args));
  1039   return SAFE_FREE_UNBIND_TO (count, elt);
  1040 }
  1041 
  1042 DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
  1043        doc: /* If TEST yields non-nil, eval BODY... and repeat.
  1044 The order of execution is thus TEST, BODY, TEST, BODY and so on
  1045 until TEST returns nil.
  1046 
  1047 The value of a `while' form is always nil.
  1048 
  1049 usage: (while TEST BODY...)  */)
  1050   (Lisp_Object args)
  1051 {
  1052   Lisp_Object test, body;
  1053 
  1054   test = XCAR (args);
  1055   body = XCDR (args);
  1056   while (!NILP (eval_sub (test)))
  1057     {
  1058       maybe_quit ();
  1059       prog_ignore (body);
  1060     }
  1061 
  1062   return Qnil;
  1063 }
  1064 
  1065 static void
  1066 with_delayed_message_display (struct atimer *timer)
  1067 {
  1068   message3 (build_string (timer->client_data));
  1069 }
  1070 
  1071 static void
  1072 with_delayed_message_cancel (void *timer)
  1073 {
  1074   xfree (((struct atimer *) timer)->client_data);
  1075   cancel_atimer (timer);
  1076 }
  1077 
  1078 DEFUN ("funcall-with-delayed-message",
  1079        Ffuncall_with_delayed_message, Sfuncall_with_delayed_message,
  1080        3, 3, 0,
  1081        doc: /* Like `funcall', but display MESSAGE if FUNCTION takes longer than TIMEOUT.
  1082 TIMEOUT is a number of seconds, and can be an integer or a floating
  1083 point number.
  1084 
  1085 If FUNCTION takes less time to execute than TIMEOUT seconds, MESSAGE
  1086 is not displayed.  */)
  1087   (Lisp_Object timeout, Lisp_Object message, Lisp_Object function)
  1088 {
  1089   specpdl_ref count = SPECPDL_INDEX ();
  1090 
  1091   CHECK_NUMBER (timeout);
  1092   CHECK_STRING (message);
  1093 
  1094   /* Set up the atimer.  */
  1095   struct timespec interval = dtotimespec (XFLOATINT (timeout));
  1096   struct atimer *timer = start_atimer (ATIMER_RELATIVE, interval,
  1097                                        with_delayed_message_display,
  1098                                        xstrdup (SSDATA (message)));
  1099   record_unwind_protect_ptr (with_delayed_message_cancel, timer);
  1100 
  1101   Lisp_Object result = CALLN (Ffuncall, function);
  1102 
  1103   return unbind_to (count, result);
  1104 }
  1105 
  1106 DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
  1107        doc: /* Return result of expanding macros at top level of FORM.
  1108 If FORM is not a macro call, it is returned unchanged.
  1109 Otherwise, the macro is expanded and the expansion is considered
  1110 in place of FORM.  When a non-macro-call results, it is returned.
  1111 
  1112 The second optional arg ENVIRONMENT specifies an environment of macro
  1113 definitions to shadow the loaded ones for use in file byte-compilation.  */)
  1114   (Lisp_Object form, Lisp_Object environment)
  1115 {
  1116   /* With cleanups from Hallvard Furuseth.  */
  1117   register Lisp_Object expander, sym, def, tem;
  1118 
  1119   while (1)
  1120     {
  1121       /* Come back here each time we expand a macro call,
  1122          in case it expands into another macro call.  */
  1123       if (!CONSP (form))
  1124         break;
  1125       /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
  1126       def = sym = XCAR (form);
  1127       tem = Qnil;
  1128       /* Trace symbols aliases to other symbols
  1129          until we get a symbol that is not an alias.  */
  1130       while (SYMBOLP (def))
  1131         {
  1132           maybe_quit ();
  1133           sym = def;
  1134           tem = Fassq (sym, environment);
  1135           if (NILP (tem))
  1136             {
  1137               def = XSYMBOL (sym)->u.s.function;
  1138               if (!NILP (def))
  1139                 continue;
  1140             }
  1141           break;
  1142         }
  1143       /* Right now TEM is the result from SYM in ENVIRONMENT,
  1144          and if TEM is nil then DEF is SYM's function definition.  */
  1145       if (NILP (tem))
  1146         {
  1147           /* SYM is not mentioned in ENVIRONMENT.
  1148              Look at its function definition.  */
  1149           def = Fautoload_do_load (def, sym, Qmacro);
  1150           if (!CONSP (def))
  1151             /* Not defined or definition not suitable.  */
  1152             break;
  1153           if (!EQ (XCAR (def), Qmacro))
  1154             break;
  1155           else expander = XCDR (def);
  1156         }
  1157       else
  1158         {
  1159           expander = XCDR (tem);
  1160           if (NILP (expander))
  1161             break;
  1162         }
  1163       {
  1164         Lisp_Object newform = apply1 (expander, XCDR (form));
  1165         if (EQ (form, newform))
  1166           break;
  1167         else
  1168           form = newform;
  1169       }
  1170     }
  1171   return form;
  1172 }
  1173 
  1174 DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
  1175        doc: /* Eval BODY allowing nonlocal exits using `throw'.
  1176 TAG is evalled to get the tag to use; it must not be nil.
  1177 
  1178 Then the BODY is executed.
  1179 Within BODY, a call to `throw' with the same TAG exits BODY and this `catch'.
  1180 If no throw happens, `catch' returns the value of the last BODY form.
  1181 If a throw happens, it specifies the value to return from `catch'.
  1182 usage: (catch TAG BODY...)  */)
  1183   (Lisp_Object args)
  1184 {
  1185   Lisp_Object tag = eval_sub (XCAR (args));
  1186   return internal_catch (tag, Fprogn, XCDR (args));
  1187 }
  1188 
  1189 /* Assert that E is true, but do not evaluate E.  Use this instead of
  1190    eassert (E) when E contains variables that might be clobbered by a
  1191    longjmp.  */
  1192 
  1193 #define clobbered_eassert(E) verify (sizeof (E) != 0)
  1194 
  1195 /* Set up a catch, then call C function FUNC on argument ARG.
  1196    FUNC should return a Lisp_Object.
  1197    This is how catches are done from within C code.  */
  1198 
  1199 Lisp_Object
  1200 internal_catch (Lisp_Object tag,
  1201                 Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
  1202 {
  1203   /* This structure is made part of the chain `catchlist'.  */
  1204   struct handler *c = push_handler (tag, CATCHER);
  1205 
  1206   /* Call FUNC.  */
  1207   if (! sys_setjmp (c->jmp))
  1208     {
  1209       Lisp_Object val = func (arg);
  1210       eassert (handlerlist == c);
  1211       handlerlist = c->next;
  1212       return val;
  1213     }
  1214   else
  1215     { /* Throw works by a longjmp that comes right here.  */
  1216       Lisp_Object val = handlerlist->val;
  1217       clobbered_eassert (handlerlist == c);
  1218       handlerlist = handlerlist->next;
  1219       return val;
  1220     }
  1221 }
  1222 
  1223 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
  1224    jump to that CATCH, returning VALUE as the value of that catch.
  1225 
  1226    This is the guts of Fthrow and Fsignal; they differ only in the way
  1227    they choose the catch tag to throw to.  A catch tag for a
  1228    condition-case form has a TAG of Qnil.
  1229 
  1230    Before each catch is discarded, unbind all special bindings and
  1231    execute all unwind-protect clauses made above that catch.  Unwind
  1232    the handler stack as we go, so that the proper handlers are in
  1233    effect for each unwind-protect clause we run.  At the end, restore
  1234    some static info saved in CATCH, and longjmp to the location
  1235    specified there.
  1236 
  1237    This is used for correct unwinding in Fthrow and Fsignal.  */
  1238 
  1239 static AVOID
  1240 unwind_to_catch (struct handler *catch, enum nonlocal_exit type,
  1241                  Lisp_Object value)
  1242 {
  1243   bool last_time;
  1244 
  1245   eassert (catch->next);
  1246 
  1247   /* Save the value in the tag.  */
  1248   catch->nonlocal_exit = type;
  1249   catch->val = value;
  1250 
  1251   /* Restore certain special C variables.  */
  1252   set_poll_suppress_count (catch->poll_suppress_count);
  1253   unblock_input_to (catch->interrupt_input_blocked);
  1254 
  1255 #ifdef HAVE_X_WINDOWS
  1256   /* Restore the X error handler stack.  This is important because
  1257      otherwise a display disconnect won't unwind the stack of error
  1258      traps to the right depth.  */
  1259   x_unwind_errors_to (catch->x_error_handler_depth);
  1260 #endif
  1261 
  1262   do
  1263     {
  1264       /* Unwind the specpdl stack, and then restore the proper set of
  1265          handlers.  */
  1266       unbind_to (handlerlist->pdlcount, Qnil);
  1267       last_time = handlerlist == catch;
  1268       if (! last_time)
  1269         handlerlist = handlerlist->next;
  1270     }
  1271   while (! last_time);
  1272 
  1273   eassert (handlerlist == catch);
  1274 
  1275   lisp_eval_depth = catch->f_lisp_eval_depth;
  1276   set_act_rec (current_thread, catch->act_rec);
  1277 
  1278   sys_longjmp (catch->jmp, 1);
  1279 }
  1280 
  1281 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
  1282        doc: /* Throw to the catch for TAG and return VALUE from it.
  1283 Both TAG and VALUE are evalled.  */
  1284        attributes: noreturn)
  1285   (register Lisp_Object tag, Lisp_Object value)
  1286 {
  1287   struct handler *c;
  1288 
  1289   if (!NILP (tag))
  1290     for (c = handlerlist; c; c = c->next)
  1291       {
  1292         if (c->type == CATCHER_ALL)
  1293           unwind_to_catch (c, NONLOCAL_EXIT_THROW, Fcons (tag, value));
  1294         if (c->type == CATCHER && EQ (c->tag_or_ch, tag))
  1295           unwind_to_catch (c, NONLOCAL_EXIT_THROW, value);
  1296       }
  1297   xsignal2 (Qno_catch, tag, value);
  1298 }
  1299 
  1300 
  1301 DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
  1302        doc: /* Do BODYFORM, protecting with UNWINDFORMS.
  1303 If BODYFORM completes normally, its value is returned
  1304 after executing the UNWINDFORMS.
  1305 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
  1306 usage: (unwind-protect BODYFORM UNWINDFORMS...)  */)
  1307   (Lisp_Object args)
  1308 {
  1309   Lisp_Object val;
  1310   specpdl_ref count = SPECPDL_INDEX ();
  1311 
  1312   record_unwind_protect (prog_ignore, XCDR (args));
  1313   val = eval_sub (XCAR (args));
  1314   return unbind_to (count, val);
  1315 }
  1316 
  1317 DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
  1318        doc: /* Regain control when an error is signaled.
  1319 Executes BODYFORM and returns its value if no error happens.
  1320 Each element of HANDLERS looks like (CONDITION-NAME BODY...)
  1321 or (:success BODY...), where the BODY is made of Lisp expressions.
  1322 
  1323 A handler is applicable to an error if CONDITION-NAME is one of the
  1324 error's condition names.  Handlers may also apply when non-error
  1325 symbols are signaled (e.g., `quit').  A CONDITION-NAME of t applies to
  1326 any symbol, including non-error symbols.  If multiple handlers are
  1327 applicable, only the first one runs.
  1328 
  1329 The car of a handler may be a list of condition names instead of a
  1330 single condition name; then it handles all of them.  If the special
  1331 condition name `debug' is present in this list, it allows another
  1332 condition in the list to run the debugger if `debug-on-error' and the
  1333 other usual mechanisms say it should (otherwise, `condition-case'
  1334 suppresses the debugger).
  1335 
  1336 When a handler handles an error, control returns to the `condition-case'
  1337 and it executes the handler's BODY...
  1338 with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
  1339 \(If VAR is nil, the handler can't access that information.)
  1340 Then the value of the last BODY form is returned from the `condition-case'
  1341 expression.
  1342 
  1343 The special handler (:success BODY...) is invoked if BODYFORM terminated
  1344 without signaling an error.  BODY is then evaluated with VAR bound to
  1345 the value returned by BODYFORM.
  1346 
  1347 See also the function `signal' for more info.
  1348 usage: (condition-case VAR BODYFORM &rest HANDLERS)  */)
  1349   (Lisp_Object args)
  1350 {
  1351   Lisp_Object var = XCAR (args);
  1352   Lisp_Object bodyform = XCAR (XCDR (args));
  1353   Lisp_Object handlers = XCDR (XCDR (args));
  1354 
  1355   return internal_lisp_condition_case (var, bodyform, handlers);
  1356 }
  1357 
  1358 /* Like Fcondition_case, but the args are separate
  1359    rather than passed in a list.  Used by Fbyte_code.  */
  1360 
  1361 Lisp_Object
  1362 internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
  1363                               Lisp_Object handlers)
  1364 {
  1365   struct handler *oldhandlerlist = handlerlist;
  1366   ptrdiff_t CACHEABLE clausenb = 0;
  1367 
  1368   CHECK_SYMBOL (var);
  1369 
  1370   Lisp_Object success_handler = Qnil;
  1371 
  1372   for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
  1373     {
  1374       Lisp_Object tem = XCAR (tail);
  1375       if (! (NILP (tem)
  1376              || (CONSP (tem)
  1377                  && (SYMBOLP (XCAR (tem))
  1378                      || CONSP (XCAR (tem))))))
  1379         error ("Invalid condition handler: %s",
  1380                SDATA (Fprin1_to_string (tem, Qt, Qnil)));
  1381       if (CONSP (tem) && EQ (XCAR (tem), QCsuccess))
  1382         success_handler = tem;
  1383       else
  1384         clausenb++;
  1385     }
  1386 
  1387   /* The first clause is the one that should be checked first, so it
  1388      should be added to handlerlist last.  So build in CLAUSES a table
  1389      that contains HANDLERS but in reverse order.  CLAUSES is pointer
  1390      to volatile to avoid issues with setjmp and local storage.
  1391      SAFE_ALLOCA won't work here due to the setjmp, so impose a
  1392      MAX_ALLOCA limit.  */
  1393   if (MAX_ALLOCA / word_size < clausenb)
  1394     memory_full (SIZE_MAX);
  1395   Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses);
  1396   clauses += clausenb;
  1397   for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
  1398     {
  1399       Lisp_Object tem = XCAR (tail);
  1400       if (!(CONSP (tem) && EQ (XCAR (tem), QCsuccess)))
  1401         *--clauses = tem;
  1402     }
  1403   for (ptrdiff_t i = 0; i < clausenb; i++)
  1404     {
  1405       Lisp_Object clause = clauses[i];
  1406       Lisp_Object condition = CONSP (clause) ? XCAR (clause) : Qnil;
  1407       if (!CONSP (condition))
  1408         condition = list1 (condition);
  1409       struct handler *c = push_handler (condition, CONDITION_CASE);
  1410       if (sys_setjmp (c->jmp))
  1411         {
  1412           Lisp_Object val = handlerlist->val;
  1413           Lisp_Object volatile *chosen_clause = clauses;
  1414           for (struct handler *h = handlerlist->next; h != oldhandlerlist;
  1415                h = h->next)
  1416             chosen_clause++;
  1417           Lisp_Object handler_body = XCDR (*chosen_clause);
  1418           handlerlist = oldhandlerlist;
  1419 
  1420           if (NILP (var))
  1421             return Fprogn (handler_body);
  1422 
  1423           Lisp_Object handler_var = var;
  1424           if (!NILP (Vinternal_interpreter_environment))
  1425             {
  1426               val = Fcons (Fcons (var, val),
  1427                            Vinternal_interpreter_environment);
  1428               handler_var = Qinternal_interpreter_environment;
  1429             }
  1430 
  1431           /* Bind HANDLER_VAR to VAL while evaluating HANDLER_BODY.
  1432              The unbind_to undoes just this binding; whoever longjumped
  1433              to us unwound the stack to C->pdlcount before throwing.  */
  1434           specpdl_ref count = SPECPDL_INDEX ();
  1435           specbind (handler_var, val);
  1436           return unbind_to (count, Fprogn (handler_body));
  1437         }
  1438     }
  1439 
  1440   Lisp_Object CACHEABLE result = eval_sub (bodyform);
  1441   handlerlist = oldhandlerlist;
  1442   if (!NILP (success_handler))
  1443     {
  1444       if (NILP (var))
  1445         return Fprogn (XCDR (success_handler));
  1446 
  1447       Lisp_Object handler_var = var;
  1448       if (!NILP (Vinternal_interpreter_environment))
  1449         {
  1450           result = Fcons (Fcons (var, result),
  1451                        Vinternal_interpreter_environment);
  1452           handler_var = Qinternal_interpreter_environment;
  1453         }
  1454 
  1455       specpdl_ref count = SPECPDL_INDEX ();
  1456       specbind (handler_var, result);
  1457       return unbind_to (count, Fprogn (XCDR (success_handler)));
  1458     }
  1459   return result;
  1460 }
  1461 
  1462 /* Call the function BFUN with no arguments, catching errors within it
  1463    according to HANDLERS.  If there is an error, call HFUN with
  1464    one argument which is the data that describes the error:
  1465    (SIGNALNAME . DATA)
  1466 
  1467    HANDLERS can be a list of conditions to catch.
  1468    If HANDLERS is Qt, catch all errors.
  1469    If HANDLERS is Qerror, catch all errors
  1470    but allow the debugger to run if that is enabled.  */
  1471 
  1472 Lisp_Object
  1473 internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
  1474                          Lisp_Object (*hfun) (Lisp_Object))
  1475 {
  1476   struct handler *c = push_handler (handlers, CONDITION_CASE);
  1477   if (sys_setjmp (c->jmp))
  1478     {
  1479       Lisp_Object val = handlerlist->val;
  1480       clobbered_eassert (handlerlist == c);
  1481       handlerlist = handlerlist->next;
  1482       return hfun (val);
  1483     }
  1484   else
  1485     {
  1486       Lisp_Object val = bfun ();
  1487       eassert (handlerlist == c);
  1488       handlerlist = c->next;
  1489       return val;
  1490     }
  1491 }
  1492 
  1493 /* Like internal_condition_case but call BFUN with ARG as its argument.  */
  1494 
  1495 Lisp_Object
  1496 internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
  1497                            Lisp_Object handlers,
  1498                            Lisp_Object (*hfun) (Lisp_Object))
  1499 {
  1500   struct handler *c = push_handler (handlers, CONDITION_CASE);
  1501   if (sys_setjmp (c->jmp))
  1502     {
  1503       Lisp_Object val = handlerlist->val;
  1504       clobbered_eassert (handlerlist == c);
  1505       handlerlist = handlerlist->next;
  1506       return hfun (val);
  1507     }
  1508   else
  1509     {
  1510       Lisp_Object val = bfun (arg);
  1511       eassert (handlerlist == c);
  1512       handlerlist = c->next;
  1513       return val;
  1514     }
  1515 }
  1516 
  1517 /* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
  1518    its arguments.  */
  1519 
  1520 Lisp_Object
  1521 internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
  1522                            Lisp_Object arg1,
  1523                            Lisp_Object arg2,
  1524                            Lisp_Object handlers,
  1525                            Lisp_Object (*hfun) (Lisp_Object))
  1526 {
  1527   struct handler *c = push_handler (handlers, CONDITION_CASE);
  1528   if (sys_setjmp (c->jmp))
  1529     {
  1530       Lisp_Object val = handlerlist->val;
  1531       clobbered_eassert (handlerlist == c);
  1532       handlerlist = handlerlist->next;
  1533       return hfun (val);
  1534     }
  1535   else
  1536     {
  1537       Lisp_Object val = bfun (arg1, arg2);
  1538       eassert (handlerlist == c);
  1539       handlerlist = c->next;
  1540       return val;
  1541     }
  1542 }
  1543 
  1544 /* Like internal_condition_case but call BFUN with NARGS as first,
  1545    and ARGS as second argument.  */
  1546 
  1547 Lisp_Object
  1548 internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
  1549                            ptrdiff_t nargs,
  1550                            Lisp_Object *args,
  1551                            Lisp_Object handlers,
  1552                            Lisp_Object (*hfun) (Lisp_Object err,
  1553                                                 ptrdiff_t nargs,
  1554                                                 Lisp_Object *args))
  1555 {
  1556   struct handler *old_deep = redisplay_deep_handler;
  1557   struct handler *c = push_handler (handlers, CONDITION_CASE);
  1558   if (redisplaying_p)
  1559     redisplay_deep_handler = c;
  1560   if (sys_setjmp (c->jmp))
  1561     {
  1562       Lisp_Object val = handlerlist->val;
  1563       clobbered_eassert (handlerlist == c);
  1564       handlerlist = handlerlist->next;
  1565       redisplay_deep_handler = old_deep;
  1566       return hfun (val, nargs, args);
  1567     }
  1568   else
  1569     {
  1570       Lisp_Object val = bfun (nargs, args);
  1571       eassert (handlerlist == c);
  1572       handlerlist = c->next;
  1573       redisplay_deep_handler = old_deep;
  1574       return val;
  1575     }
  1576 }
  1577 
  1578 static Lisp_Object Qcatch_all_memory_full;
  1579 
  1580 /* Like a combination of internal_condition_case_1 and internal_catch.
  1581    Catches all signals and throws.  Never exits nonlocally; returns
  1582    Qcatch_all_memory_full if no handler could be allocated.  */
  1583 
  1584 Lisp_Object
  1585 internal_catch_all (Lisp_Object (*function) (void *), void *argument,
  1586                     Lisp_Object (*handler) (enum nonlocal_exit, Lisp_Object))
  1587 {
  1588   struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
  1589   if (c == NULL)
  1590     return Qcatch_all_memory_full;
  1591 
  1592   if (sys_setjmp (c->jmp) == 0)
  1593     {
  1594       Lisp_Object val = function (argument);
  1595       eassert (handlerlist == c);
  1596       handlerlist = c->next;
  1597       return val;
  1598     }
  1599   else
  1600     {
  1601       eassert (handlerlist == c);
  1602       enum nonlocal_exit type = c->nonlocal_exit;
  1603       Lisp_Object val = c->val;
  1604       handlerlist = c->next;
  1605       return handler (type, val);
  1606     }
  1607 }
  1608 
  1609 struct handler *
  1610 push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
  1611 {
  1612   struct handler *c = push_handler_nosignal (tag_ch_val, handlertype);
  1613   if (!c)
  1614     memory_full (sizeof *c);
  1615   return c;
  1616 }
  1617 
  1618 struct handler *
  1619 push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
  1620 {
  1621   struct handler *CACHEABLE c = handlerlist->nextfree;
  1622   if (!c)
  1623     {
  1624       c = malloc (sizeof *c);
  1625       if (!c)
  1626         return c;
  1627       if (profiler_memory_running)
  1628         malloc_probe (sizeof *c);
  1629       c->nextfree = NULL;
  1630       handlerlist->nextfree = c;
  1631     }
  1632   c->type = handlertype;
  1633   c->tag_or_ch = tag_ch_val;
  1634   c->val = Qnil;
  1635   c->next = handlerlist;
  1636   c->f_lisp_eval_depth = lisp_eval_depth;
  1637   c->pdlcount = SPECPDL_INDEX ();
  1638   c->act_rec = get_act_rec (current_thread);
  1639   c->poll_suppress_count = poll_suppress_count;
  1640   c->interrupt_input_blocked = interrupt_input_blocked;
  1641 #ifdef HAVE_X_WINDOWS
  1642   c->x_error_handler_depth = x_error_message_count;
  1643 #endif
  1644   handlerlist = c;
  1645   return c;
  1646 }
  1647 
  1648 
  1649 static Lisp_Object signal_or_quit (Lisp_Object, Lisp_Object, bool);
  1650 static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object);
  1651 static bool maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
  1652                                  Lisp_Object data);
  1653 
  1654 static void
  1655 process_quit_flag (void)
  1656 {
  1657   Lisp_Object flag = Vquit_flag;
  1658   Vquit_flag = Qnil;
  1659   if (EQ (flag, Qkill_emacs))
  1660     Fkill_emacs (Qnil, Qnil);
  1661   if (EQ (Vthrow_on_input, flag))
  1662     Fthrow (Vthrow_on_input, Qt);
  1663   quit ();
  1664 }
  1665 
  1666 void
  1667 probably_quit (void)
  1668 {
  1669   specpdl_ref gc_count = inhibit_garbage_collection ();
  1670   if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
  1671     process_quit_flag ();
  1672   else if (pending_signals)
  1673     process_pending_signals ();
  1674   unbind_to (gc_count, Qnil);
  1675 }
  1676 
  1677 DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
  1678        doc: /* Signal an error.  Args are ERROR-SYMBOL and associated DATA.
  1679 This function does not return.
  1680 
  1681 An error symbol is a symbol with an `error-conditions' property
  1682 that is a list of condition names.  The symbol should be non-nil.
  1683 A handler for any of those names will get to handle this signal.
  1684 The symbol `error' should normally be one of them.
  1685 
  1686 DATA should be a list.  Its elements are printed as part of the error message.
  1687 See Info anchor `(elisp)Definition of signal' for some details on how this
  1688 error message is constructed.
  1689 If the signal is handled, DATA is made available to the handler.
  1690 See also the function `condition-case'.  */
  1691        attributes: noreturn)
  1692   (Lisp_Object error_symbol, Lisp_Object data)
  1693 {
  1694   /* If they call us with nonsensical arguments, produce "peculiar error".  */
  1695   if (NILP (error_symbol) && NILP (data))
  1696     error_symbol = Qerror;
  1697   signal_or_quit (error_symbol, data, false);
  1698   eassume (false);
  1699 }
  1700 
  1701 /* Quit, in response to a keyboard quit request.  */
  1702 Lisp_Object
  1703 quit (void)
  1704 {
  1705   return signal_or_quit (Qquit, Qnil, true);
  1706 }
  1707 
  1708 /* Has an error in redisplay giving rise to a backtrace occurred as
  1709    yet in the current command?  This gets reset in the command
  1710    loop.  */
  1711 bool backtrace_yet = false;
  1712 
  1713 /* Signal an error, or quit.  ERROR_SYMBOL and DATA are as with Fsignal.
  1714    If KEYBOARD_QUIT, this is a quit; ERROR_SYMBOL should be
  1715    Qquit and DATA should be Qnil, and this function may return.
  1716    Otherwise this function is like Fsignal and does not return.  */
  1717 
  1718 static Lisp_Object
  1719 signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
  1720 {
  1721   /* When memory is full, ERROR-SYMBOL is nil,
  1722      and DATA is (REAL-ERROR-SYMBOL . REAL-DATA).
  1723      That is a special case--don't do this in other situations.  */
  1724   Lisp_Object conditions;
  1725   Lisp_Object string;
  1726   Lisp_Object real_error_symbol
  1727     = (NILP (error_symbol) ? Fcar (data) : error_symbol);
  1728   Lisp_Object clause = Qnil;
  1729   struct handler *h;
  1730 
  1731   if (gc_in_progress || waiting_for_input)
  1732     emacs_abort ();
  1733 
  1734 #if 0 /* rms: I don't know why this was here,
  1735          but it is surely wrong for an error that is handled.  */
  1736 #ifdef HAVE_WINDOW_SYSTEM
  1737   if (display_hourglass_p)
  1738     cancel_hourglass ();
  1739 #endif
  1740 #endif
  1741 
  1742   /* This hook is used by edebug.  */
  1743   if (! NILP (Vsignal_hook_function)
  1744       && ! NILP (error_symbol)
  1745       /* Don't try to call a lisp function if we've already overflowed
  1746          the specpdl stack.  */
  1747       && specpdl_ptr < specpdl_end)
  1748     {
  1749       /* Edebug takes care of restoring these variables when it exits.  */
  1750       max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 20);
  1751 
  1752       call2 (Vsignal_hook_function, error_symbol, data);
  1753     }
  1754 
  1755   conditions = Fget (real_error_symbol, Qerror_conditions);
  1756 
  1757   /* Remember from where signal was called.  Skip over the frame for
  1758      `signal' itself.  If a frame for `error' follows, skip that,
  1759      too.  Don't do this when ERROR_SYMBOL is nil, because that
  1760      is a memory-full error.  */
  1761   Vsignaling_function = Qnil;
  1762   if (!NILP (error_symbol))
  1763     {
  1764       union specbinding *pdl = backtrace_next (backtrace_top ());
  1765       if (backtrace_p (pdl) && EQ (backtrace_function (pdl), Qerror))
  1766         pdl = backtrace_next (pdl);
  1767       if (backtrace_p (pdl))
  1768         Vsignaling_function = backtrace_function (pdl);
  1769     }
  1770 
  1771   for (h = handlerlist; h; h = h->next)
  1772     {
  1773       if (h->type == CATCHER_ALL)
  1774         {
  1775           clause = Qt;
  1776           break;
  1777         }
  1778       if (h->type != CONDITION_CASE)
  1779         continue;
  1780       clause = find_handler_clause (h->tag_or_ch, conditions);
  1781       if (!NILP (clause))
  1782         break;
  1783     }
  1784 
  1785   bool debugger_called = false;
  1786   if (/* Don't run the debugger for a memory-full error.
  1787          (There is no room in memory to do that!)  */
  1788       !NILP (error_symbol)
  1789       && (!NILP (Vdebug_on_signal)
  1790           /* If no handler is present now, try to run the debugger.  */
  1791           || NILP (clause)
  1792           /* A `debug' symbol in the handler list disables the normal
  1793              suppression of the debugger.  */
  1794           || (CONSP (clause) && !NILP (Fmemq (Qdebug, clause)))
  1795           /* Special handler that means "print a message and run debugger
  1796              if requested".  */
  1797           || EQ (h->tag_or_ch, Qerror)))
  1798     {
  1799       debugger_called
  1800         = maybe_call_debugger (conditions, error_symbol, data);
  1801       /* We can't return values to code which signaled an error, but we
  1802          can continue code which has signaled a quit.  */
  1803       if (keyboard_quit && debugger_called && EQ (real_error_symbol, Qquit))
  1804         return Qnil;
  1805     }
  1806 
  1807   /* If we're in batch mode, print a backtrace unconditionally to help
  1808      with debugging.  Make sure to use `debug-early' unconditionally
  1809      to not interfere with ERT or other packages that install custom
  1810      debuggers.  */
  1811   if (!debugger_called && !NILP (error_symbol)
  1812       && (NILP (clause) || EQ (h->tag_or_ch, Qerror))
  1813       && noninteractive && backtrace_on_error_noninteractive
  1814       && NILP (Vinhibit_debugger)
  1815       && !NILP (Ffboundp (Qdebug_early)))
  1816     {
  1817       max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
  1818       specpdl_ref count = SPECPDL_INDEX ();
  1819       specbind (Qdebugger, Qdebug_early);
  1820       call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
  1821       unbind_to (count, Qnil);
  1822     }
  1823 
  1824   /* If an error is signaled during a Lisp hook in redisplay, write a
  1825      backtrace into the buffer *Redisplay-trace*.  */
  1826   if (!debugger_called && !NILP (error_symbol)
  1827       && backtrace_on_redisplay_error
  1828       && (NILP (clause) || h == redisplay_deep_handler)
  1829       && NILP (Vinhibit_debugger)
  1830       && !NILP (Ffboundp (Qdebug_early)))
  1831     {
  1832       max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
  1833       specpdl_ref count = SPECPDL_INDEX ();
  1834       AUTO_STRING (redisplay_trace, "*Redisplay_trace*");
  1835       Lisp_Object redisplay_trace_buffer;
  1836       AUTO_STRING (gap, "\n\n\n\n"); /* Separates things in *Redisplay-trace* */
  1837       Lisp_Object delayed_warning;
  1838       redisplay_trace_buffer = Fget_buffer_create (redisplay_trace, Qnil);
  1839       current_buffer = XBUFFER (redisplay_trace_buffer);
  1840       if (!backtrace_yet) /* Are we on the first backtrace of the command?  */
  1841         Ferase_buffer ();
  1842       else
  1843         Finsert (1, &gap);
  1844       backtrace_yet = true;
  1845       specbind (Qstandard_output, redisplay_trace_buffer);
  1846       specbind (Qdebugger, Qdebug_early);
  1847       call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
  1848       unbind_to (count, Qnil);
  1849       delayed_warning = make_string
  1850         ("Error in a redisplay Lisp hook.  See buffer *Redisplay_trace*", 61);
  1851 
  1852       Vdelayed_warnings_list = Fcons (list2 (Qerror, delayed_warning),
  1853                                       Vdelayed_warnings_list);
  1854     }
  1855 
  1856   if (!NILP (clause))
  1857     {
  1858       Lisp_Object unwind_data
  1859         = (NILP (error_symbol) ? data : Fcons (error_symbol, data));
  1860 
  1861       unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, unwind_data);
  1862     }
  1863   else
  1864     {
  1865       if (handlerlist != handlerlist_sentinel)
  1866         /* FIXME: This will come right back here if there's no `top-level'
  1867            catcher.  A better solution would be to abort here, and instead
  1868            add a catch-all condition handler so we never come here.  */
  1869         Fthrow (Qtop_level, Qt);
  1870     }
  1871 
  1872   if (! NILP (error_symbol))
  1873     data = Fcons (error_symbol, data);
  1874 
  1875   string = Ferror_message_string (data);
  1876   fatal ("%s", SDATA (string));
  1877 }
  1878 
  1879 /* Like xsignal, but takes 0, 1, 2, or 3 args instead of a list.  */
  1880 
  1881 void
  1882 xsignal0 (Lisp_Object error_symbol)
  1883 {
  1884   xsignal (error_symbol, Qnil);
  1885 }
  1886 
  1887 void
  1888 xsignal1 (Lisp_Object error_symbol, Lisp_Object arg)
  1889 {
  1890   xsignal (error_symbol, list1 (arg));
  1891 }
  1892 
  1893 void
  1894 xsignal2 (Lisp_Object error_symbol, Lisp_Object arg1, Lisp_Object arg2)
  1895 {
  1896   xsignal (error_symbol, list2 (arg1, arg2));
  1897 }
  1898 
  1899 void
  1900 xsignal3 (Lisp_Object error_symbol, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
  1901 {
  1902   xsignal (error_symbol, list3 (arg1, arg2, arg3));
  1903 }
  1904 
  1905 /* Signal `error' with message S, and additional arg ARG.
  1906    If ARG is not a proper list, make it a one-element list.  */
  1907 
  1908 void
  1909 signal_error (const char *s, Lisp_Object arg)
  1910 {
  1911   if (NILP (Fproper_list_p (arg)))
  1912     arg = list1 (arg);
  1913 
  1914   xsignal (Qerror, Fcons (build_string (s), arg));
  1915 }
  1916 
  1917 void
  1918 define_error (Lisp_Object name, const char *message, Lisp_Object parent)
  1919 {
  1920   eassert (SYMBOLP (name));
  1921   eassert (SYMBOLP (parent));
  1922   Lisp_Object parent_conditions = Fget (parent, Qerror_conditions);
  1923   eassert (CONSP (parent_conditions));
  1924   eassert (!NILP (Fmemq (parent, parent_conditions)));
  1925   eassert (NILP (Fmemq (name, parent_conditions)));
  1926   Fput (name, Qerror_conditions, pure_cons (name, parent_conditions));
  1927   Fput (name, Qerror_message, build_pure_c_string (message));
  1928 }
  1929 
  1930 /* Use this for arithmetic overflow, e.g., when an integer result is
  1931    too large even for a bignum.  */
  1932 void
  1933 overflow_error (void)
  1934 {
  1935   xsignal0 (Qoverflow_error);
  1936 }
  1937 
  1938 
  1939 /* Return true if LIST is a non-nil atom or
  1940    a list containing one of CONDITIONS.  */
  1941 
  1942 static bool
  1943 wants_debugger (Lisp_Object list, Lisp_Object conditions)
  1944 {
  1945   if (NILP (list))
  1946     return 0;
  1947   if (! CONSP (list))
  1948     return 1;
  1949 
  1950   while (CONSP (conditions))
  1951     {
  1952       Lisp_Object this, tail;
  1953       this = XCAR (conditions);
  1954       for (tail = list; CONSP (tail); tail = XCDR (tail))
  1955         if (EQ (XCAR (tail), this))
  1956           return 1;
  1957       conditions = XCDR (conditions);
  1958     }
  1959   return 0;
  1960 }
  1961 
  1962 /* Return true if an error with condition-symbols CONDITIONS,
  1963    and described by SIGNAL-DATA, should skip the debugger
  1964    according to debugger-ignored-errors.  */
  1965 
  1966 static bool
  1967 skip_debugger (Lisp_Object conditions, Lisp_Object data)
  1968 {
  1969   Lisp_Object tail;
  1970   bool first_string = 1;
  1971   Lisp_Object error_message;
  1972 
  1973   error_message = Qnil;
  1974   for (tail = Vdebug_ignored_errors; CONSP (tail); tail = XCDR (tail))
  1975     {
  1976       if (STRINGP (XCAR (tail)))
  1977         {
  1978           if (first_string)
  1979             {
  1980               error_message = Ferror_message_string (data);
  1981               first_string = 0;
  1982             }
  1983 
  1984           if (fast_string_match (XCAR (tail), error_message) >= 0)
  1985             return 1;
  1986         }
  1987       else
  1988         {
  1989           Lisp_Object contail;
  1990 
  1991           for (contail = conditions; CONSP (contail); contail = XCDR (contail))
  1992             if (EQ (XCAR (tail), XCAR (contail)))
  1993               return 1;
  1994         }
  1995     }
  1996 
  1997   return 0;
  1998 }
  1999 
  2000 /* Say whether SIGNAL is a `quit' symbol (or inherits from it).  */
  2001 bool
  2002 signal_quit_p (Lisp_Object signal)
  2003 {
  2004   Lisp_Object list;
  2005 
  2006   return EQ (signal, Qquit)
  2007     || (!NILP (Fsymbolp (signal))
  2008         && CONSP (list = Fget (signal, Qerror_conditions))
  2009         && !NILP (Fmemq (Qquit, list)));
  2010 }
  2011 
  2012 /* Call the debugger if calling it is currently enabled for CONDITIONS.
  2013    SIG and DATA describe the signal.  There are two ways to pass them:
  2014     = SIG is the error symbol, and DATA is the rest of the data.
  2015     = SIG is nil, and DATA is (SYMBOL . REST-OF-DATA).
  2016       This is for memory-full errors only.  */
  2017 static bool
  2018 maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data)
  2019 {
  2020   Lisp_Object combined_data;
  2021 
  2022   combined_data = Fcons (sig, data);
  2023 
  2024   if (
  2025       /* Don't try to run the debugger with interrupts blocked.
  2026          The editing loop would return anyway.  */
  2027       ! input_blocked_p ()
  2028       && NILP (Vinhibit_debugger)
  2029       /* Does user want to enter debugger for this kind of error?  */
  2030       && (signal_quit_p (sig)
  2031           ? debug_on_quit
  2032           : wants_debugger (Vdebug_on_error, conditions))
  2033       && ! skip_debugger (conditions, combined_data)
  2034       /* See commentary on definition of
  2035          `internal-when-entered-debugger'.  */
  2036       && when_entered_debugger < num_nonmacro_input_events)
  2037     {
  2038       call_debugger (list2 (Qerror, combined_data));
  2039       return 1;
  2040     }
  2041 
  2042   return 0;
  2043 }
  2044 
  2045 static Lisp_Object
  2046 find_handler_clause (Lisp_Object handlers, Lisp_Object conditions)
  2047 {
  2048   register Lisp_Object h;
  2049 
  2050   /* t is used by handlers for all conditions, set up by C code.  */
  2051   if (EQ (handlers, Qt))
  2052     return Qt;
  2053 
  2054   /* error is used similarly, but means print an error message
  2055      and run the debugger if that is enabled.  */
  2056   if (EQ (handlers, Qerror))
  2057     return Qt;
  2058 
  2059   for (h = handlers; CONSP (h); h = XCDR (h))
  2060     {
  2061       Lisp_Object handler = XCAR (h);
  2062       if (!NILP (Fmemq (handler, conditions))
  2063           /* t is also used as a catch-all by Lisp code.  */
  2064           || EQ (handler, Qt))
  2065         return handlers;
  2066     }
  2067 
  2068   return Qnil;
  2069 }
  2070 
  2071 
  2072 /* Format and return a string; called like vprintf.  */
  2073 Lisp_Object
  2074 vformat_string (const char *m, va_list ap)
  2075 {
  2076   char buf[4000];
  2077   ptrdiff_t size = sizeof buf;
  2078   ptrdiff_t size_max = STRING_BYTES_BOUND + 1;
  2079   char *buffer = buf;
  2080   ptrdiff_t used;
  2081   Lisp_Object string;
  2082 
  2083   used = evxprintf (&buffer, &size, buf, size_max, m, ap);
  2084   string = make_string (buffer, used);
  2085   if (buffer != buf)
  2086     xfree (buffer);
  2087 
  2088   return string;
  2089 }
  2090 
  2091 /* Dump an error message; called like vprintf.  */
  2092 void
  2093 verror (const char *m, va_list ap)
  2094 {
  2095   xsignal1 (Qerror, vformat_string (m, ap));
  2096 }
  2097 
  2098 
  2099 /* Dump an error message; called like printf.  */
  2100 
  2101 void
  2102 error (const char *m, ...)
  2103 {
  2104   va_list ap;
  2105   va_start (ap, m);
  2106   verror (m, ap);
  2107 }
  2108 
  2109 DEFUN ("commandp", Fcommandp, Scommandp, 1, 2, 0,
  2110        doc: /* Non-nil if FUNCTION makes provisions for interactive calling.
  2111 This means it contains a description for how to read arguments to give it.
  2112 The value is nil for an invalid function or a symbol with no function
  2113 definition.
  2114 
  2115 Interactively callable functions include strings and vectors (treated
  2116 as keyboard macros), lambda-expressions that contain a top-level call
  2117 to `interactive', autoload definitions made by `autoload' with non-nil
  2118 fourth argument, and some of the built-in functions of Lisp.
  2119 
  2120 Also, a symbol satisfies `commandp' if its function definition does so.
  2121 
  2122 If the optional argument FOR-CALL-INTERACTIVELY is non-nil,
  2123 then strings and vectors are not accepted.  */)
  2124   (Lisp_Object function, Lisp_Object for_call_interactively)
  2125 {
  2126   register Lisp_Object fun;
  2127   bool genfun = false; /* If true, we should consult `interactive-form'.  */
  2128 
  2129   fun = function;
  2130 
  2131   fun = indirect_function (fun);
  2132   if (NILP (fun))
  2133     return Qnil;
  2134 
  2135   /* Emacs primitives are interactive if their DEFUN specifies an
  2136      interactive spec.  */
  2137   if (SUBRP (fun))
  2138     {
  2139       if (XSUBR (fun)->intspec.string)
  2140         return Qt;
  2141     }
  2142   /* Bytecode objects are interactive if they are long enough to
  2143      have an element whose index is COMPILED_INTERACTIVE, which is
  2144      where the interactive spec is stored.  */
  2145   else if (COMPILEDP (fun))
  2146     {
  2147       if (PVSIZE (fun) > COMPILED_INTERACTIVE)
  2148         return Qt;
  2149       else if (PVSIZE (fun) > COMPILED_DOC_STRING)
  2150         {
  2151           Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING);
  2152           /* An invalid "docstring" is a sign that we have an OClosure.  */
  2153           genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc));
  2154         }
  2155     }
  2156 
  2157 #ifdef HAVE_MODULES
  2158   /* Module functions are interactive if their `interactive_form'
  2159      field is non-nil. */
  2160   else if (MODULE_FUNCTIONP (fun))
  2161     {
  2162       if (!NILP (module_function_interactive_form (XMODULE_FUNCTION (fun))))
  2163         return Qt;
  2164     }
  2165 #endif
  2166 
  2167   /* Strings and vectors are keyboard macros.  */
  2168   else if (STRINGP (fun) || VECTORP (fun))
  2169     return (NILP (for_call_interactively) ? Qt : Qnil);
  2170 
  2171   /* Lists may represent commands.  */
  2172   else if (!CONSP (fun))
  2173     return Qnil;
  2174   else
  2175     {
  2176       Lisp_Object funcar = XCAR (fun);
  2177       if (EQ (funcar, Qautoload))
  2178         {
  2179           if (!NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))))
  2180             return Qt;
  2181         }
  2182       else
  2183         {
  2184           Lisp_Object body = CDR_SAFE (XCDR (fun));
  2185           if (EQ (funcar, Qclosure))
  2186             body = CDR_SAFE (body);
  2187           else if (!EQ (funcar, Qlambda))
  2188             return Qnil;
  2189           if (!NILP (Fassq (Qinteractive, body)))
  2190             return Qt;
  2191           else if (VALID_DOCSTRING_P (CAR_SAFE (body)))
  2192             /* A "docstring" is a sign that we may have an OClosure.  */
  2193             genfun = true;
  2194         }
  2195     }
  2196 
  2197   /* By now, if it's not a function we already returned nil.  */
  2198 
  2199   /* Check an `interactive-form' property if present, analogous to the
  2200      function-documentation property.  */
  2201   fun = function;
  2202   while (SYMBOLP (fun))
  2203     {
  2204       Lisp_Object tmp = Fget (fun, Qinteractive_form);
  2205       if (!NILP (tmp))
  2206         error ("Found an 'interactive-form' property!");
  2207       fun = Fsymbol_function (fun);
  2208     }
  2209 
  2210   /* If there's no immediate interactive form but it's an OClosure,
  2211      then delegate to the generic-function in case it has
  2212      a type-specific interactive-form.  */
  2213   if (genfun)
  2214     {
  2215       Lisp_Object iform = call1 (Qinteractive_form, fun);
  2216       return NILP (iform) ? Qnil : Qt;
  2217     }
  2218   else
  2219     return Qnil;
  2220 }
  2221 
  2222 DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
  2223        doc: /* Define FUNCTION to autoload from FILE.
  2224 FUNCTION is a symbol; FILE is a file name string to pass to `load'.
  2225 
  2226 Third arg DOCSTRING is documentation for the function.
  2227 
  2228 Fourth arg INTERACTIVE if non-nil says function can be called
  2229 interactively.  If INTERACTIVE is a list, it is interpreted as a list
  2230 of modes the function is applicable for.
  2231 
  2232 Fifth arg TYPE indicates the type of the object:
  2233    nil or omitted says FUNCTION is a function,
  2234    `keymap' says FUNCTION is really a keymap, and
  2235    `macro' or t says FUNCTION is really a macro.
  2236 
  2237 Third through fifth args give info about the real definition.
  2238 They default to nil.
  2239 
  2240 If FUNCTION is already defined other than as an autoload,
  2241 this does nothing and returns nil.  */)
  2242   (Lisp_Object function, Lisp_Object file, Lisp_Object docstring, Lisp_Object interactive, Lisp_Object type)
  2243 {
  2244   CHECK_SYMBOL (function);
  2245   CHECK_STRING (file);
  2246 
  2247   /* If function is defined and not as an autoload, don't override.  */
  2248   if (!NILP (XSYMBOL (function)->u.s.function)
  2249       && !AUTOLOADP (XSYMBOL (function)->u.s.function))
  2250     return Qnil;
  2251 
  2252   if (!NILP (Vpurify_flag) && BASE_EQ (docstring, make_fixnum (0)))
  2253     /* `read1' in lread.c has found the docstring starting with "\
  2254        and assumed the docstring will be provided by Snarf-documentation, so it
  2255        passed us 0 instead.  But that leads to accidental sharing in purecopy's
  2256        hash-consing, so we use a (hopefully) unique integer instead.  */
  2257     docstring = make_ufixnum (XHASH (function));
  2258   return Fdefalias (function,
  2259                     list5 (Qautoload, file, docstring, interactive, type),
  2260                     Qnil);
  2261 }
  2262 
  2263 static void
  2264 un_autoload (Lisp_Object oldqueue)
  2265 {
  2266   /* Queue to unwind is current value of Vautoload_queue.
  2267      oldqueue is the shadowed value to leave in Vautoload_queue.  */
  2268   Lisp_Object queue = Vautoload_queue;
  2269   Vautoload_queue = oldqueue;
  2270   while (CONSP (queue))
  2271     {
  2272       Lisp_Object first = XCAR (queue);
  2273       if (CONSP (first) && BASE_EQ (XCAR (first), make_fixnum (0)))
  2274         Vfeatures = XCDR (first);
  2275       else
  2276         Ffset (first, Fcar (Fcdr (Fget (first, Qfunction_history))));
  2277       queue = XCDR (queue);
  2278     }
  2279 }
  2280 
  2281 Lisp_Object
  2282 load_with_autoload_queue
  2283   (Lisp_Object file, Lisp_Object noerror, Lisp_Object nomessage,
  2284    Lisp_Object nosuffix, Lisp_Object must_suffix)
  2285 {
  2286   specpdl_ref count = SPECPDL_INDEX ();
  2287 
  2288   /* If autoloading gets an error (which includes the error of failing
  2289      to define the function being called), we use Vautoload_queue
  2290      to undo function definitions and `provide' calls made by
  2291      the function.  We do this in the specific case of autoloading
  2292      because autoloading is not an explicit request "load this file",
  2293      but rather a request to "call this function".
  2294 
  2295      The value saved here is to be restored into Vautoload_queue.  */
  2296   record_unwind_protect (un_autoload, Vautoload_queue);
  2297   Vautoload_queue = Qt;
  2298   Lisp_Object tem
  2299     = save_match_data_load (file, noerror, nomessage, nosuffix, must_suffix);
  2300 
  2301   /* Once loading finishes, don't undo it.  */
  2302   Vautoload_queue = Qt;
  2303   unbind_to (count, Qnil);
  2304   return tem;
  2305 }
  2306 
  2307 /* Load an autoloaded function.
  2308    FUNNAME is the symbol which is the function's name.
  2309    FUNDEF is the autoload definition (a list).  */
  2310 
  2311 DEFUN ("autoload-do-load", Fautoload_do_load, Sautoload_do_load, 1, 3, 0,
  2312        doc: /* Load FUNDEF which should be an autoload.
  2313 If non-nil, FUNNAME should be the symbol whose function value is FUNDEF,
  2314 in which case the function returns the new autoloaded function value.
  2315 If equal to `macro', MACRO-ONLY specifies that FUNDEF should only be loaded if
  2316 it defines a macro.  */)
  2317   (Lisp_Object fundef, Lisp_Object funname, Lisp_Object macro_only)
  2318 {
  2319   if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef)))
  2320     return fundef;
  2321 
  2322   Lisp_Object kind = Fnth (make_fixnum (4), fundef);
  2323   if (EQ (macro_only, Qmacro)
  2324       && !(EQ (kind, Qt) || EQ (kind, Qmacro)))
  2325     return fundef;
  2326 
  2327   /* This is to make sure that loadup.el gives a clear picture
  2328      of what files are preloaded and when.  */
  2329   if (will_dump_p () && !will_bootstrap_p ())
  2330     {
  2331       /* Avoid landing here recursively while outputting the
  2332          backtrace from the error.  */
  2333       gflags.will_dump_ = false;
  2334       error ("Attempt to autoload %s while preparing to dump",
  2335              SDATA (SYMBOL_NAME (funname)));
  2336     }
  2337 
  2338   CHECK_SYMBOL (funname);
  2339 
  2340   /* If `macro_only' is set and fundef isn't a macro, assume this autoload to
  2341      be a "best-effort" (e.g. to try and find a compiler macro),
  2342      so don't signal an error if autoloading fails.  */
  2343   Lisp_Object ignore_errors
  2344     = (EQ (kind, Qt) || EQ (kind, Qmacro)) ? Qnil : macro_only;
  2345   load_with_autoload_queue (Fcar (Fcdr (fundef)), ignore_errors, Qt, Qnil, Qt);
  2346 
  2347   if (NILP (funname) || !NILP (ignore_errors))
  2348     return Qnil;
  2349   else
  2350     {
  2351       Lisp_Object fun = Findirect_function (funname, Qnil);
  2352 
  2353       if (!NILP (Fequal (fun, fundef)))
  2354         error ("Autoloading file %s failed to define function %s",
  2355                SDATA (Fcar (Fcar (Vload_history))),
  2356                SDATA (SYMBOL_NAME (funname)));
  2357       else
  2358         return fun;
  2359     }
  2360 }
  2361 
  2362 
  2363 static Lisp_Object list_of_t;  /* Never-modified constant containing (t).  */
  2364 
  2365 DEFUN ("eval", Feval, Seval, 1, 2, 0,
  2366        doc: /* Evaluate FORM and return its value.
  2367 If LEXICAL is t, evaluate using lexical scoping.
  2368 LEXICAL can also be an actual lexical environment, in the form of an
  2369 alist mapping symbols to their value.  */)
  2370   (Lisp_Object form, Lisp_Object lexical)
  2371 {
  2372   specpdl_ref count = SPECPDL_INDEX ();
  2373   specbind (Qinternal_interpreter_environment,
  2374             CONSP (lexical) || NILP (lexical) ? lexical : list_of_t);
  2375   return unbind_to (count, eval_sub (form));
  2376 }
  2377 
  2378 void
  2379 grow_specpdl_allocation (void)
  2380 {
  2381   eassert (specpdl_ptr == specpdl_end);
  2382 
  2383   specpdl_ref count = SPECPDL_INDEX ();
  2384   ptrdiff_t max_size = PTRDIFF_MAX - 1000;
  2385   union specbinding *pdlvec = specpdl - 1;
  2386   ptrdiff_t size = specpdl_end - specpdl;
  2387   ptrdiff_t pdlvecsize = size + 1;
  2388   eassert (max_size > size);
  2389   pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
  2390   specpdl = pdlvec + 1;
  2391   specpdl_end = specpdl + pdlvecsize - 1;
  2392   specpdl_ptr = specpdl_ref_to_ptr (count);
  2393 }
  2394 
  2395 /* Eval a sub-expression of the current expression (i.e. in the same
  2396    lexical scope).  */
  2397 Lisp_Object
  2398 eval_sub (Lisp_Object form)
  2399 {
  2400   if (SYMBOLP (form))
  2401     {
  2402       /* Look up its binding in the lexical environment.
  2403          We do not pay attention to the declared_special flag here, since we
  2404          already did that when let-binding the variable.  */
  2405       Lisp_Object lex_binding
  2406         = Fassq (form, Vinternal_interpreter_environment);
  2407       return !NILP (lex_binding) ? XCDR (lex_binding) : Fsymbol_value (form);
  2408     }
  2409 
  2410   if (!CONSP (form))
  2411     return form;
  2412 
  2413   maybe_quit ();
  2414 
  2415   maybe_gc ();
  2416 
  2417   if (++lisp_eval_depth > max_lisp_eval_depth)
  2418     {
  2419       if (max_lisp_eval_depth < 100)
  2420         max_lisp_eval_depth = 100;
  2421       if (lisp_eval_depth > max_lisp_eval_depth)
  2422         xsignal1 (Qexcessive_lisp_nesting, make_fixnum (lisp_eval_depth));
  2423     }
  2424 
  2425   Lisp_Object original_fun = XCAR (form);
  2426   Lisp_Object original_args = XCDR (form);
  2427   CHECK_LIST (original_args);
  2428 
  2429   /* This also protects them from gc.  */
  2430   specpdl_ref count
  2431     = record_in_backtrace (original_fun, &original_args, UNEVALLED);
  2432 
  2433   if (debug_on_next_call)
  2434     do_debug_on_call (Qt, count);
  2435 
  2436   Lisp_Object fun, val, funcar;
  2437   /* Declare here, as this array may be accessed by call_debugger near
  2438      the end of this function.  See Bug#21245.  */
  2439   Lisp_Object argvals[8];
  2440 
  2441  retry:
  2442 
  2443   /* Optimize for no indirection.  */
  2444   fun = original_fun;
  2445   if (!SYMBOLP (fun))
  2446     fun = Ffunction (list1 (fun));
  2447   else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
  2448     fun = indirect_function (fun);
  2449 
  2450   if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
  2451     {
  2452       Lisp_Object args_left = original_args;
  2453       ptrdiff_t numargs = list_length (args_left);
  2454 
  2455       if (numargs < XSUBR (fun)->min_args
  2456           || (XSUBR (fun)->max_args >= 0
  2457               && XSUBR (fun)->max_args < numargs))
  2458         xsignal2 (Qwrong_number_of_arguments, original_fun,
  2459                   make_fixnum (numargs));
  2460 
  2461       else if (XSUBR (fun)->max_args == UNEVALLED)
  2462         val = (XSUBR (fun)->function.aUNEVALLED) (args_left);
  2463       else if (XSUBR (fun)->max_args == MANY
  2464                || XSUBR (fun)->max_args > 8)
  2465 
  2466         {
  2467           /* Pass a vector of evaluated arguments.  */
  2468           Lisp_Object *vals;
  2469           ptrdiff_t argnum = 0;
  2470           USE_SAFE_ALLOCA;
  2471 
  2472           SAFE_ALLOCA_LISP (vals, numargs);
  2473 
  2474           while (CONSP (args_left) && argnum < numargs)
  2475             {
  2476               Lisp_Object arg = XCAR (args_left);
  2477               args_left = XCDR (args_left);
  2478               vals[argnum++] = eval_sub (arg);
  2479             }
  2480 
  2481           set_backtrace_args (specpdl_ref_to_ptr (count), vals, argnum);
  2482 
  2483           val = XSUBR (fun)->function.aMANY (argnum, vals);
  2484 
  2485           lisp_eval_depth--;
  2486           /* Do the debug-on-exit now, while VALS still exists.  */
  2487           if (backtrace_debug_on_exit (specpdl_ref_to_ptr (count)))
  2488             val = call_debugger (list2 (Qexit, val));
  2489           SAFE_FREE ();
  2490           specpdl_ptr--;
  2491           return val;
  2492         }
  2493       else
  2494         {
  2495           int i, maxargs = XSUBR (fun)->max_args;
  2496 
  2497           for (i = 0; i < maxargs; i++)
  2498             {
  2499               argvals[i] = eval_sub (Fcar (args_left));
  2500               args_left = Fcdr (args_left);
  2501             }
  2502 
  2503           set_backtrace_args (specpdl_ref_to_ptr (count), argvals, numargs);
  2504 
  2505           switch (i)
  2506             {
  2507             case 0:
  2508               val = (XSUBR (fun)->function.a0 ());
  2509               break;
  2510             case 1:
  2511               val = (XSUBR (fun)->function.a1 (argvals[0]));
  2512               break;
  2513             case 2:
  2514               val = (XSUBR (fun)->function.a2 (argvals[0], argvals[1]));
  2515               break;
  2516             case 3:
  2517               val = (XSUBR (fun)->function.a3
  2518                      (argvals[0], argvals[1], argvals[2]));
  2519               break;
  2520             case 4:
  2521               val = (XSUBR (fun)->function.a4
  2522                      (argvals[0], argvals[1], argvals[2], argvals[3]));
  2523               break;
  2524             case 5:
  2525               val = (XSUBR (fun)->function.a5
  2526                      (argvals[0], argvals[1], argvals[2], argvals[3],
  2527                       argvals[4]));
  2528               break;
  2529             case 6:
  2530               val = (XSUBR (fun)->function.a6
  2531                      (argvals[0], argvals[1], argvals[2], argvals[3],
  2532                       argvals[4], argvals[5]));
  2533               break;
  2534             case 7:
  2535               val = (XSUBR (fun)->function.a7
  2536                      (argvals[0], argvals[1], argvals[2], argvals[3],
  2537                       argvals[4], argvals[5], argvals[6]));
  2538               break;
  2539 
  2540             case 8:
  2541               val = (XSUBR (fun)->function.a8
  2542                      (argvals[0], argvals[1], argvals[2], argvals[3],
  2543                       argvals[4], argvals[5], argvals[6], argvals[7]));
  2544               break;
  2545 
  2546             default:
  2547               /* Someone has created a subr that takes more arguments than
  2548                  is supported by this code.  We need to either rewrite the
  2549                  subr to use a different argument protocol, or add more
  2550                  cases to this switch.  */
  2551               emacs_abort ();
  2552             }
  2553         }
  2554     }
  2555   else if (COMPILEDP (fun)
  2556            || SUBR_NATIVE_COMPILED_DYNP (fun)
  2557            || MODULE_FUNCTIONP (fun))
  2558     return apply_lambda (fun, original_args, count);
  2559   else
  2560     {
  2561       if (NILP (fun))
  2562         xsignal1 (Qvoid_function, original_fun);
  2563       if (!CONSP (fun))
  2564         xsignal1 (Qinvalid_function, original_fun);
  2565       funcar = XCAR (fun);
  2566       if (!SYMBOLP (funcar))
  2567         xsignal1 (Qinvalid_function, original_fun);
  2568       if (EQ (funcar, Qautoload))
  2569         {
  2570           Fautoload_do_load (fun, original_fun, Qnil);
  2571           goto retry;
  2572         }
  2573       if (EQ (funcar, Qmacro))
  2574         {
  2575           specpdl_ref count1 = SPECPDL_INDEX ();
  2576           Lisp_Object exp;
  2577           /* Bind lexical-binding during expansion of the macro, so the
  2578              macro can know reliably if the code it outputs will be
  2579              interpreted using lexical-binding or not.  */
  2580           specbind (Qlexical_binding,
  2581                     NILP (Vinternal_interpreter_environment) ? Qnil : Qt);
  2582 
  2583           /* Make the macro aware of any defvar declarations in scope. */
  2584           Lisp_Object dynvars = Vmacroexp__dynvars;
  2585           for (Lisp_Object p = Vinternal_interpreter_environment;
  2586                !NILP (p); p = XCDR(p))
  2587             {
  2588               Lisp_Object e = XCAR (p);
  2589               if (SYMBOLP (e))
  2590                 dynvars = Fcons(e, dynvars);
  2591             }
  2592           if (!EQ (dynvars, Vmacroexp__dynvars))
  2593             specbind (Qmacroexp__dynvars, dynvars);
  2594 
  2595           exp = apply1 (Fcdr (fun), original_args);
  2596           exp = unbind_to (count1, exp);
  2597           val = eval_sub (exp);
  2598         }
  2599       else if (EQ (funcar, Qlambda)
  2600                || EQ (funcar, Qclosure))
  2601         return apply_lambda (fun, original_args, count);
  2602       else
  2603         xsignal1 (Qinvalid_function, original_fun);
  2604     }
  2605 
  2606   lisp_eval_depth--;
  2607   if (backtrace_debug_on_exit (specpdl_ref_to_ptr (count)))
  2608     val = call_debugger (list2 (Qexit, val));
  2609   specpdl_ptr--;
  2610 
  2611   return val;
  2612 }
  2613 
  2614 DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
  2615        doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
  2616 Then return the value FUNCTION returns.
  2617 With a single argument, call the argument's first element using the
  2618 other elements as args.
  2619 Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
  2620 usage: (apply FUNCTION &rest ARGUMENTS)  */)
  2621   (ptrdiff_t nargs, Lisp_Object *args)
  2622 {
  2623   ptrdiff_t i, funcall_nargs;
  2624   Lisp_Object *funcall_args = NULL;
  2625   Lisp_Object spread_arg = args[nargs - 1];
  2626   Lisp_Object fun = args[0];
  2627   USE_SAFE_ALLOCA;
  2628 
  2629   ptrdiff_t numargs = list_length (spread_arg);
  2630 
  2631   if (numargs == 0)
  2632     return Ffuncall (max (1, nargs - 1), args);
  2633   else if (numargs == 1)
  2634     {
  2635       args [nargs - 1] = XCAR (spread_arg);
  2636       return Ffuncall (nargs, args);
  2637     }
  2638 
  2639   numargs += nargs - 2;
  2640 
  2641   /* Optimize for no indirection.  */
  2642   if (SYMBOLP (fun) && !NILP (fun)
  2643       && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
  2644     {
  2645       fun = indirect_function (fun);
  2646       if (NILP (fun))
  2647         /* Let funcall get the error.  */
  2648         fun = args[0];
  2649     }
  2650 
  2651   if (SUBRP (fun) && XSUBR (fun)->max_args > numargs
  2652       /* Don't hide an error by adding missing arguments.  */
  2653       && numargs >= XSUBR (fun)->min_args)
  2654     {
  2655       /* Avoid making funcall cons up a yet another new vector of arguments
  2656          by explicitly supplying nil's for optional values.  */
  2657       SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
  2658       memclear (funcall_args + numargs + 1,
  2659                 (XSUBR (fun)->max_args - numargs) * word_size);
  2660       funcall_nargs = 1 + XSUBR (fun)->max_args;
  2661     }
  2662   else
  2663     { /* We add 1 to numargs because funcall_args includes the
  2664          function itself as well as its arguments.  */
  2665       SAFE_ALLOCA_LISP (funcall_args, 1 + numargs);
  2666       funcall_nargs = 1 + numargs;
  2667     }
  2668 
  2669   memcpy (funcall_args, args, nargs * word_size);
  2670   /* Spread the last arg we got.  Its first element goes in
  2671      the slot that it used to occupy, hence this value of I.  */
  2672   i = nargs - 1;
  2673   while (!NILP (spread_arg))
  2674     {
  2675       funcall_args [i++] = XCAR (spread_arg);
  2676       spread_arg = XCDR (spread_arg);
  2677     }
  2678 
  2679   Lisp_Object retval = Ffuncall (funcall_nargs, funcall_args);
  2680 
  2681   SAFE_FREE ();
  2682   return retval;
  2683 }
  2684 
  2685 /* Run hook variables in various ways.  */
  2686 
  2687 static Lisp_Object
  2688 funcall_nil (ptrdiff_t nargs, Lisp_Object *args)
  2689 {
  2690   Ffuncall (nargs, args);
  2691   return Qnil;
  2692 }
  2693 
  2694 DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
  2695        doc: /* Run each hook in HOOKS.
  2696 Each argument should be a symbol, a hook variable.
  2697 These symbols are processed in the order specified.
  2698 If a hook symbol has a non-nil value, that value may be a function
  2699 or a list of functions to be called to run the hook.
  2700 If the value is a function, it is called with no arguments.
  2701 If it is a list, the elements are called, in order, with no arguments.
  2702 
  2703 Major modes should not use this function directly to run their mode
  2704 hook; they should use `run-mode-hooks' instead.
  2705 
  2706 Do not use `make-local-variable' to make a hook variable buffer-local.
  2707 Instead, use `add-hook' and specify t for the LOCAL argument.
  2708 usage: (run-hooks &rest HOOKS)  */)
  2709   (ptrdiff_t nargs, Lisp_Object *args)
  2710 {
  2711   ptrdiff_t i;
  2712 
  2713   for (i = 0; i < nargs; i++)
  2714     run_hook (args[i]);
  2715 
  2716   return Qnil;
  2717 }
  2718 
  2719 DEFUN ("run-hook-with-args", Frun_hook_with_args,
  2720        Srun_hook_with_args, 1, MANY, 0,
  2721        doc: /* Run HOOK with the specified arguments ARGS.
  2722 HOOK should be a symbol, a hook variable.  The value of HOOK
  2723 may be nil, a function, or a list of functions.  Call each
  2724 function in order with arguments ARGS.  The final return value
  2725 is unspecified.
  2726 
  2727 Do not use `make-local-variable' to make a hook variable buffer-local.
  2728 Instead, use `add-hook' and specify t for the LOCAL argument.
  2729 usage: (run-hook-with-args HOOK &rest ARGS)  */)
  2730   (ptrdiff_t nargs, Lisp_Object *args)
  2731 {
  2732   return run_hook_with_args (nargs, args, funcall_nil);
  2733 }
  2734 
  2735 /* NB this one still documents a specific non-nil return value.
  2736    (As did run-hook-with-args and run-hook-with-args-until-failure
  2737    until they were changed in 24.1.)  */
  2738 DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success,
  2739        Srun_hook_with_args_until_success, 1, MANY, 0,
  2740        doc: /* Run HOOK with the specified arguments ARGS.
  2741 HOOK should be a symbol, a hook variable.  The value of HOOK
  2742 may be nil, a function, or a list of functions.  Call each
  2743 function in order with arguments ARGS, stopping at the first
  2744 one that returns non-nil, and return that value.  Otherwise (if
  2745 all functions return nil, or if there are no functions to call),
  2746 return nil.
  2747 
  2748 Do not use `make-local-variable' to make a hook variable buffer-local.
  2749 Instead, use `add-hook' and specify t for the LOCAL argument.
  2750 usage: (run-hook-with-args-until-success HOOK &rest ARGS)  */)
  2751   (ptrdiff_t nargs, Lisp_Object *args)
  2752 {
  2753   return run_hook_with_args (nargs, args, Ffuncall);
  2754 }
  2755 
  2756 static Lisp_Object
  2757 funcall_not (ptrdiff_t nargs, Lisp_Object *args)
  2758 {
  2759   return NILP (Ffuncall (nargs, args)) ? Qt : Qnil;
  2760 }
  2761 
  2762 DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
  2763        Srun_hook_with_args_until_failure, 1, MANY, 0,
  2764        doc: /* Run HOOK with the specified arguments ARGS.
  2765 HOOK should be a symbol, a hook variable.  The value of HOOK
  2766 may be nil, a function, or a list of functions.  Call each
  2767 function in order with arguments ARGS, stopping at the first
  2768 one that returns nil, and return nil.  Otherwise (if all functions
  2769 return non-nil, or if there are no functions to call), return non-nil
  2770 \(do not rely on the precise return value in this case).
  2771 
  2772 Do not use `make-local-variable' to make a hook variable buffer-local.
  2773 Instead, use `add-hook' and specify t for the LOCAL argument.
  2774 usage: (run-hook-with-args-until-failure HOOK &rest ARGS)  */)
  2775   (ptrdiff_t nargs, Lisp_Object *args)
  2776 {
  2777   return NILP (run_hook_with_args (nargs, args, funcall_not)) ? Qt : Qnil;
  2778 }
  2779 
  2780 static Lisp_Object
  2781 run_hook_wrapped_funcall (ptrdiff_t nargs, Lisp_Object *args)
  2782 {
  2783   Lisp_Object tmp = args[0], ret;
  2784   args[0] = args[1];
  2785   args[1] = tmp;
  2786   ret = Ffuncall (nargs, args);
  2787   args[1] = args[0];
  2788   args[0] = tmp;
  2789   return ret;
  2790 }
  2791 
  2792 DEFUN ("run-hook-wrapped", Frun_hook_wrapped, Srun_hook_wrapped, 2, MANY, 0,
  2793        doc: /* Run HOOK, passing each function through WRAP-FUNCTION.
  2794 I.e. instead of calling each function FUN directly with arguments ARGS,
  2795 it calls WRAP-FUNCTION with arguments FUN and ARGS.
  2796 As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
  2797 aborts and returns that value.
  2798 usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS)  */)
  2799      (ptrdiff_t nargs, Lisp_Object *args)
  2800 {
  2801   return run_hook_with_args (nargs, args, run_hook_wrapped_funcall);
  2802 }
  2803 
  2804 /* ARGS[0] should be a hook symbol.
  2805    Call each of the functions in the hook value, passing each of them
  2806    as arguments all the rest of ARGS (all NARGS - 1 elements).
  2807    FUNCALL specifies how to call each function on the hook.  */
  2808 
  2809 Lisp_Object
  2810 run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args,
  2811                     Lisp_Object (*funcall) (ptrdiff_t nargs, Lisp_Object *args))
  2812 {
  2813   Lisp_Object sym, val, ret = Qnil;
  2814 
  2815   /* If we are dying or still initializing,
  2816      don't do anything--it would probably crash if we tried.  */
  2817   if (NILP (Vrun_hooks))
  2818     return Qnil;
  2819 
  2820   sym = args[0];
  2821   val = find_symbol_value (sym);
  2822 
  2823   if (BASE_EQ (val, Qunbound) || NILP (val))
  2824     return ret;
  2825   else if (!CONSP (val) || FUNCTIONP (val))
  2826     {
  2827       args[0] = val;
  2828       return funcall (nargs, args);
  2829     }
  2830   else
  2831     {
  2832       Lisp_Object global_vals = Qnil;
  2833 
  2834       for (;
  2835            CONSP (val) && NILP (ret);
  2836            val = XCDR (val))
  2837         {
  2838           if (EQ (XCAR (val), Qt))
  2839             {
  2840               /* t indicates this hook has a local binding;
  2841                  it means to run the global binding too.  */
  2842               global_vals = Fdefault_value (sym);
  2843               if (NILP (global_vals)) continue;
  2844 
  2845               if (!CONSP (global_vals) || EQ (XCAR (global_vals), Qlambda))
  2846                 {
  2847                   args[0] = global_vals;
  2848                   ret = funcall (nargs, args);
  2849                 }
  2850               else
  2851                 {
  2852                   for (;
  2853                        CONSP (global_vals) && NILP (ret);
  2854                        global_vals = XCDR (global_vals))
  2855                     {
  2856                       args[0] = XCAR (global_vals);
  2857                       /* In a global value, t should not occur.  If it does, we
  2858                          must ignore it to avoid an endless loop.  */
  2859                       if (!EQ (args[0], Qt))
  2860                         ret = funcall (nargs, args);
  2861                     }
  2862                 }
  2863             }
  2864           else
  2865             {
  2866               args[0] = XCAR (val);
  2867               ret = funcall (nargs, args);
  2868             }
  2869         }
  2870 
  2871       return ret;
  2872     }
  2873 }
  2874 
  2875 /* Run the hook HOOK, giving each function no args.  */
  2876 
  2877 void
  2878 run_hook (Lisp_Object hook)
  2879 {
  2880   Frun_hook_with_args (1, &hook);
  2881 }
  2882 
  2883 /* Run the hook HOOK, giving each function the two args ARG1 and ARG2.  */
  2884 
  2885 void
  2886 run_hook_with_args_2 (Lisp_Object hook, Lisp_Object arg1, Lisp_Object arg2)
  2887 {
  2888   CALLN (Frun_hook_with_args, hook, arg1, arg2);
  2889 }
  2890 
  2891 /* Apply fn to arg.  */
  2892 Lisp_Object
  2893 apply1 (Lisp_Object fn, Lisp_Object arg)
  2894 {
  2895   return NILP (arg) ? Ffuncall (1, &fn) : CALLN (Fapply, fn, arg);
  2896 }
  2897 
  2898 DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
  2899        doc: /* Return t if OBJECT is a function.
  2900 
  2901 An object is a function if it is callable via `funcall'; this includes
  2902 symbols with function bindings, but excludes macros and special forms.
  2903 
  2904 Ordinarily return nil if OBJECT is not a function, although t might be
  2905 returned in rare cases.  */)
  2906      (Lisp_Object object)
  2907 {
  2908   if (FUNCTIONP (object))
  2909     return Qt;
  2910   return Qnil;
  2911 }
  2912 
  2913 bool
  2914 FUNCTIONP (Lisp_Object object)
  2915 {
  2916   if (SYMBOLP (object) && !NILP (Ffboundp (object)))
  2917     {
  2918       object = Findirect_function (object, Qt);
  2919 
  2920       if (CONSP (object) && EQ (XCAR (object), Qautoload))
  2921         {
  2922           /* Autoloaded symbols are functions, except if they load
  2923              macros or keymaps.  */
  2924           for (int i = 0; i < 4 && CONSP (object); i++)
  2925             object = XCDR (object);
  2926 
  2927           return ! (CONSP (object) && !NILP (XCAR (object)));
  2928         }
  2929     }
  2930 
  2931   if (SUBRP (object))
  2932     return XSUBR (object)->max_args != UNEVALLED;
  2933   else if (COMPILEDP (object) || MODULE_FUNCTIONP (object))
  2934     return true;
  2935   else if (CONSP (object))
  2936     {
  2937       Lisp_Object car = XCAR (object);
  2938       return EQ (car, Qlambda) || EQ (car, Qclosure);
  2939     }
  2940   else
  2941     return false;
  2942 }
  2943 
  2944 Lisp_Object
  2945 funcall_general (Lisp_Object fun, ptrdiff_t numargs, Lisp_Object *args)
  2946 {
  2947   Lisp_Object original_fun = fun;
  2948  retry:
  2949   if (SYMBOLP (fun) && !NILP (fun)
  2950       && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
  2951     fun = indirect_function (fun);
  2952 
  2953   if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
  2954     return funcall_subr (XSUBR (fun), numargs, args);
  2955   else if (COMPILEDP (fun)
  2956            || SUBR_NATIVE_COMPILED_DYNP (fun)
  2957            || MODULE_FUNCTIONP (fun))
  2958     return funcall_lambda (fun, numargs, args);
  2959   else
  2960     {
  2961       if (NILP (fun))
  2962         xsignal1 (Qvoid_function, original_fun);
  2963       if (!CONSP (fun))
  2964         xsignal1 (Qinvalid_function, original_fun);
  2965       Lisp_Object funcar = XCAR (fun);
  2966       if (!SYMBOLP (funcar))
  2967         xsignal1 (Qinvalid_function, original_fun);
  2968       if (EQ (funcar, Qlambda)
  2969           || EQ (funcar, Qclosure))
  2970         return funcall_lambda (fun, numargs, args);
  2971       else if (EQ (funcar, Qautoload))
  2972         {
  2973           Fautoload_do_load (fun, original_fun, Qnil);
  2974           fun = original_fun;
  2975           goto retry;
  2976         }
  2977       else
  2978         xsignal1 (Qinvalid_function, original_fun);
  2979     }
  2980 }
  2981 
  2982 DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
  2983        doc: /* Call first argument as a function, passing remaining arguments to it.
  2984 Return the value that function returns.
  2985 Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
  2986 usage: (funcall FUNCTION &rest ARGUMENTS)  */)
  2987   (ptrdiff_t nargs, Lisp_Object *args)
  2988 {
  2989   specpdl_ref count;
  2990 
  2991   maybe_quit ();
  2992 
  2993   if (++lisp_eval_depth > max_lisp_eval_depth)
  2994     {
  2995       if (max_lisp_eval_depth < 100)
  2996         max_lisp_eval_depth = 100;
  2997       if (lisp_eval_depth > max_lisp_eval_depth)
  2998         xsignal1 (Qexcessive_lisp_nesting, make_fixnum (lisp_eval_depth));
  2999     }
  3000 
  3001   count = record_in_backtrace (args[0], &args[1], nargs - 1);
  3002 
  3003   maybe_gc ();
  3004 
  3005   if (debug_on_next_call)
  3006     do_debug_on_call (Qlambda, count);
  3007 
  3008   Lisp_Object val = funcall_general (args[0], nargs - 1, args + 1);
  3009 
  3010   lisp_eval_depth--;
  3011   if (backtrace_debug_on_exit (specpdl_ref_to_ptr (count)))
  3012     val = call_debugger (list2 (Qexit, val));
  3013   specpdl_ptr--;
  3014   return val;
  3015 }
  3016 
  3017 
  3018 /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR
  3019    and return the result of evaluation.  */
  3020 
  3021 Lisp_Object
  3022 funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args)
  3023 {
  3024   eassume (numargs >= 0);
  3025   if (numargs >= subr->min_args)
  3026     {
  3027       /* Conforming call to finite-arity subr.  */
  3028       if (numargs <= subr->max_args
  3029           && subr->max_args <= 8)
  3030         {
  3031           Lisp_Object argbuf[8];
  3032           Lisp_Object *a;
  3033           if (numargs < subr->max_args)
  3034             {
  3035               eassume (subr->max_args <= ARRAYELTS (argbuf));
  3036               a = argbuf;
  3037               memcpy (a, args, numargs * word_size);
  3038               memclear (a + numargs, (subr->max_args - numargs) * word_size);
  3039             }
  3040           else
  3041             a = args;
  3042           switch (subr->max_args)
  3043             {
  3044             case 0:
  3045               return subr->function.a0 ();
  3046             case 1:
  3047               return subr->function.a1 (a[0]);
  3048             case 2:
  3049               return subr->function.a2 (a[0], a[1]);
  3050             case 3:
  3051               return subr->function.a3 (a[0], a[1], a[2]);
  3052             case 4:
  3053               return subr->function.a4 (a[0], a[1], a[2], a[3]);
  3054             case 5:
  3055               return subr->function.a5 (a[0], a[1], a[2], a[3], a[4]);
  3056             case 6:
  3057               return subr->function.a6 (a[0], a[1], a[2], a[3], a[4], a[5]);
  3058             case 7:
  3059               return subr->function.a7 (a[0], a[1], a[2], a[3], a[4], a[5],
  3060                                         a[6]);
  3061             case 8:
  3062               return subr->function.a8 (a[0], a[1], a[2], a[3], a[4], a[5],
  3063                                         a[6], a[7]);
  3064             default:
  3065               emacs_abort ();   /* Can't happen. */
  3066             }
  3067         }
  3068 
  3069       /* Call to n-adic subr.  */
  3070       if (subr->max_args == MANY
  3071           || subr->max_args > 8)
  3072         return subr->function.aMANY (numargs, args);
  3073     }
  3074 
  3075   /* Anything else is an error.  */
  3076   Lisp_Object fun;
  3077   XSETSUBR (fun, subr);
  3078   if (subr->max_args == UNEVALLED)
  3079     xsignal1 (Qinvalid_function, fun);
  3080   else
  3081     xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs));
  3082 }
  3083 
  3084 /* Call the compiled Lisp function FUN.  If we have not yet read FUN's
  3085    bytecode string and constants vector, fetch them from the file first.  */
  3086 
  3087 static Lisp_Object
  3088 fetch_and_exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
  3089                           ptrdiff_t nargs, Lisp_Object *args)
  3090 {
  3091   if (CONSP (AREF (fun, COMPILED_BYTECODE)))
  3092     Ffetch_bytecode (fun);
  3093 
  3094   return exec_byte_code (fun, args_template, nargs, args);
  3095 }
  3096 
  3097 static Lisp_Object
  3098 apply_lambda (Lisp_Object fun, Lisp_Object args, specpdl_ref count)
  3099 {
  3100   Lisp_Object *arg_vector;
  3101   Lisp_Object tem;
  3102   USE_SAFE_ALLOCA;
  3103 
  3104   ptrdiff_t numargs = list_length (args);
  3105   SAFE_ALLOCA_LISP (arg_vector, numargs);
  3106   Lisp_Object args_left = args;
  3107 
  3108   for (ptrdiff_t i = 0; i < numargs; i++)
  3109     {
  3110       tem = Fcar (args_left), args_left = Fcdr (args_left);
  3111       tem = eval_sub (tem);
  3112       arg_vector[i] = tem;
  3113     }
  3114 
  3115   set_backtrace_args (specpdl_ref_to_ptr (count), arg_vector, numargs);
  3116   tem = funcall_lambda (fun, numargs, arg_vector);
  3117 
  3118   lisp_eval_depth--;
  3119   /* Do the debug-on-exit now, while arg_vector still exists.  */
  3120   if (backtrace_debug_on_exit (specpdl_ref_to_ptr (count)))
  3121     tem = call_debugger (list2 (Qexit, tem));
  3122   SAFE_FREE ();
  3123   specpdl_ptr--;
  3124   return tem;
  3125 }
  3126 
  3127 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
  3128    and return the result of evaluation.
  3129    FUN must be either a lambda-expression, a compiled-code object,
  3130    or a module function.  */
  3131 
  3132 static Lisp_Object
  3133 funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
  3134                 register Lisp_Object *arg_vector)
  3135 {
  3136   Lisp_Object val, syms_left, next, lexenv;
  3137   specpdl_ref count = SPECPDL_INDEX ();
  3138   ptrdiff_t i;
  3139   bool optional, rest;
  3140 
  3141   if (CONSP (fun))
  3142     {
  3143       if (EQ (XCAR (fun), Qclosure))
  3144         {
  3145           Lisp_Object cdr = XCDR (fun); /* Drop `closure'.  */
  3146           if (! CONSP (cdr))
  3147             xsignal1 (Qinvalid_function, fun);
  3148           fun = cdr;
  3149           lexenv = XCAR (fun);
  3150         }
  3151       else
  3152         lexenv = Qnil;
  3153       syms_left = XCDR (fun);
  3154       if (CONSP (syms_left))
  3155         syms_left = XCAR (syms_left);
  3156       else
  3157         xsignal1 (Qinvalid_function, fun);
  3158     }
  3159   else if (COMPILEDP (fun))
  3160     {
  3161       syms_left = AREF (fun, COMPILED_ARGLIST);
  3162       /* Bytecode objects using lexical binding have an integral
  3163          ARGLIST slot value: pass the arguments to the byte-code
  3164          engine directly.  */
  3165       if (FIXNUMP (syms_left))
  3166         return fetch_and_exec_byte_code (fun, XFIXNUM (syms_left),
  3167                                          nargs, arg_vector);
  3168       /* Otherwise the bytecode object uses dynamic binding and the
  3169          ARGLIST slot contains a standard formal argument list whose
  3170          variables are bound dynamically below.  */
  3171       lexenv = Qnil;
  3172     }
  3173 #ifdef HAVE_MODULES
  3174   else if (MODULE_FUNCTIONP (fun))
  3175     return funcall_module (fun, nargs, arg_vector);
  3176 #endif
  3177 #ifdef HAVE_NATIVE_COMP
  3178   else if (SUBR_NATIVE_COMPILED_DYNP (fun))
  3179     {
  3180       syms_left = XSUBR (fun)->lambda_list;
  3181       lexenv = Qnil;
  3182     }
  3183 #endif
  3184   else
  3185     emacs_abort ();
  3186 
  3187   i = optional = rest = 0;
  3188   bool previous_rest = false;
  3189   for (; CONSP (syms_left); syms_left = XCDR (syms_left))
  3190     {
  3191       maybe_quit ();
  3192 
  3193       next = XCAR (syms_left);
  3194       if (!SYMBOLP (next))
  3195         xsignal1 (Qinvalid_function, fun);
  3196 
  3197       if (EQ (next, Qand_rest))
  3198         {
  3199           if (rest || previous_rest)
  3200             xsignal1 (Qinvalid_function, fun);
  3201           rest = 1;
  3202           previous_rest = true;
  3203         }
  3204       else if (EQ (next, Qand_optional))
  3205         {
  3206           if (optional || rest || previous_rest)
  3207             xsignal1 (Qinvalid_function, fun);
  3208           optional = 1;
  3209         }
  3210       else
  3211         {
  3212           Lisp_Object arg;
  3213           if (rest)
  3214             {
  3215               arg = Flist (nargs - i, &arg_vector[i]);
  3216               i = nargs;
  3217             }
  3218           else if (i < nargs)
  3219             arg = arg_vector[i++];
  3220           else if (!optional)
  3221             xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (nargs));
  3222           else
  3223             arg = Qnil;
  3224 
  3225           /* Bind the argument.  */
  3226           if (!NILP (lexenv) && SYMBOLP (next))
  3227             /* Lexically bind NEXT by adding it to the lexenv alist.  */
  3228             lexenv = Fcons (Fcons (next, arg), lexenv);
  3229           else
  3230             /* Dynamically bind NEXT.  */
  3231             specbind (next, arg);
  3232           previous_rest = false;
  3233         }
  3234     }
  3235 
  3236   if (!NILP (syms_left) || previous_rest)
  3237     xsignal1 (Qinvalid_function, fun);
  3238   else if (i < nargs)
  3239     xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (nargs));
  3240 
  3241   if (!EQ (lexenv, Vinternal_interpreter_environment))
  3242     /* Instantiate a new lexical environment.  */
  3243     specbind (Qinternal_interpreter_environment, lexenv);
  3244 
  3245   if (CONSP (fun))
  3246     val = Fprogn (XCDR (XCDR (fun)));
  3247   else if (SUBR_NATIVE_COMPILEDP (fun))
  3248     {
  3249       eassert (SUBR_NATIVE_COMPILED_DYNP (fun));
  3250       /* No need to use funcall_subr as we have zero arguments by
  3251          construction.  */
  3252       val = XSUBR (fun)->function.a0 ();
  3253     }
  3254   else
  3255     val = fetch_and_exec_byte_code (fun, 0, 0, NULL);
  3256 
  3257   return unbind_to (count, val);
  3258 }
  3259 
  3260 DEFUN ("func-arity", Ffunc_arity, Sfunc_arity, 1, 1, 0,
  3261        doc: /* Return minimum and maximum number of args allowed for FUNCTION.
  3262 FUNCTION must be a function of some kind.
  3263 The returned value is a cons cell (MIN . MAX).  MIN is the minimum number
  3264 of args.  MAX is the maximum number, or the symbol `many', for a
  3265 function with `&rest' args, or `unevalled' for a special form.  */)
  3266   (Lisp_Object function)
  3267 {
  3268   Lisp_Object original;
  3269   Lisp_Object funcar;
  3270   Lisp_Object result;
  3271 
  3272   original = function;
  3273 
  3274  retry:
  3275 
  3276   /* Optimize for no indirection.  */
  3277   function = original;
  3278   if (SYMBOLP (function) && !NILP (function))
  3279     {
  3280       function = XSYMBOL (function)->u.s.function;
  3281       if (SYMBOLP (function))
  3282         function = indirect_function (function);
  3283     }
  3284 
  3285   if (CONSP (function) && EQ (XCAR (function), Qmacro))
  3286     function = XCDR (function);
  3287 
  3288   if (SUBRP (function))
  3289     result = Fsubr_arity (function);
  3290   else if (COMPILEDP (function))
  3291     result = lambda_arity (function);
  3292 #ifdef HAVE_MODULES
  3293   else if (MODULE_FUNCTIONP (function))
  3294     result = module_function_arity (XMODULE_FUNCTION (function));
  3295 #endif
  3296   else
  3297     {
  3298       if (NILP (function))
  3299         xsignal1 (Qvoid_function, original);
  3300       if (!CONSP (function))
  3301         xsignal1 (Qinvalid_function, original);
  3302       funcar = XCAR (function);
  3303       if (!SYMBOLP (funcar))
  3304         xsignal1 (Qinvalid_function, original);
  3305       if (EQ (funcar, Qlambda)
  3306           || EQ (funcar, Qclosure))
  3307         result = lambda_arity (function);
  3308       else if (EQ (funcar, Qautoload))
  3309         {
  3310           Fautoload_do_load (function, original, Qnil);
  3311           goto retry;
  3312         }
  3313       else
  3314         xsignal1 (Qinvalid_function, original);
  3315     }
  3316   return result;
  3317 }
  3318 
  3319 /* FUN must be either a lambda-expression or a compiled-code object.  */
  3320 static Lisp_Object
  3321 lambda_arity (Lisp_Object fun)
  3322 {
  3323   Lisp_Object syms_left;
  3324 
  3325   if (CONSP (fun))
  3326     {
  3327       if (EQ (XCAR (fun), Qclosure))
  3328         {
  3329           fun = XCDR (fun);     /* Drop `closure'.  */
  3330           CHECK_CONS (fun);
  3331         }
  3332       syms_left = XCDR (fun);
  3333       if (CONSP (syms_left))
  3334         syms_left = XCAR (syms_left);
  3335       else
  3336         xsignal1 (Qinvalid_function, fun);
  3337     }
  3338   else if (COMPILEDP (fun))
  3339     {
  3340       syms_left = AREF (fun, COMPILED_ARGLIST);
  3341       if (FIXNUMP (syms_left))
  3342         return get_byte_code_arity (syms_left);
  3343     }
  3344   else
  3345     emacs_abort ();
  3346 
  3347   EMACS_INT minargs = 0, maxargs = 0;
  3348   bool optional = false;
  3349   for (; CONSP (syms_left); syms_left = XCDR (syms_left))
  3350     {
  3351       Lisp_Object next = XCAR (syms_left);
  3352       if (!SYMBOLP (next))
  3353         xsignal1 (Qinvalid_function, fun);
  3354 
  3355       if (EQ (next, Qand_rest))
  3356         return Fcons (make_fixnum (minargs), Qmany);
  3357       else if (EQ (next, Qand_optional))
  3358         optional = true;
  3359       else
  3360         {
  3361           if (!optional)
  3362             minargs++;
  3363           maxargs++;
  3364         }
  3365     }
  3366 
  3367   if (!NILP (syms_left))
  3368     xsignal1 (Qinvalid_function, fun);
  3369 
  3370   return Fcons (make_fixnum (minargs), make_fixnum (maxargs));
  3371 }
  3372 
  3373 DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
  3374        1, 1, 0,
  3375        doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now.  */)
  3376   (Lisp_Object object)
  3377 {
  3378   Lisp_Object tem;
  3379 
  3380   if (COMPILEDP (object))
  3381     {
  3382       if (CONSP (AREF (object, COMPILED_BYTECODE)))
  3383         {
  3384           tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
  3385           if (! (CONSP (tem) && STRINGP (XCAR (tem))
  3386                  && VECTORP (XCDR (tem))))
  3387             {
  3388               tem = AREF (object, COMPILED_BYTECODE);
  3389               if (CONSP (tem) && STRINGP (XCAR (tem)))
  3390                 error ("Invalid byte code in %s", SDATA (XCAR (tem)));
  3391               else
  3392                 error ("Invalid byte code");
  3393             }
  3394 
  3395           Lisp_Object bytecode = XCAR (tem);
  3396           if (STRING_MULTIBYTE (bytecode))
  3397             {
  3398               /* BYTECODE must have been produced by Emacs 20.2 or earlier
  3399                  because it produced a raw 8-bit string for byte-code and now
  3400                  such a byte-code string is loaded as multibyte with raw 8-bit
  3401                  characters converted to multibyte form.  Convert them back to
  3402                  the original unibyte form.  */
  3403               bytecode = Fstring_as_unibyte (bytecode);
  3404             }
  3405 
  3406           pin_string (bytecode);
  3407           ASET (object, COMPILED_BYTECODE, bytecode);
  3408           ASET (object, COMPILED_CONSTANTS, XCDR (tem));
  3409         }
  3410     }
  3411   return object;
  3412 }
  3413 
  3414 /* Return true if SYMBOL's default currently has a let-binding
  3415    which was made in the buffer that is now current.  */
  3416 
  3417 bool
  3418 let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
  3419 {
  3420   union specbinding *p;
  3421   Lisp_Object buf = Fcurrent_buffer ();
  3422 
  3423   for (p = specpdl_ptr; p > specpdl; )
  3424     if ((--p)->kind > SPECPDL_LET)
  3425       {
  3426         struct Lisp_Symbol *let_bound_symbol = XSYMBOL (specpdl_symbol (p));
  3427         eassert (let_bound_symbol->u.s.redirect != SYMBOL_VARALIAS);
  3428         if (symbol == let_bound_symbol
  3429             && p->kind != SPECPDL_LET_LOCAL /* bug#62419 */
  3430             && EQ (specpdl_where (p), buf))
  3431           return 1;
  3432       }
  3433 
  3434   return 0;
  3435 }
  3436 
  3437 static void
  3438 do_specbind (struct Lisp_Symbol *sym, union specbinding *bind,
  3439              Lisp_Object value, enum Set_Internal_Bind bindflag)
  3440 {
  3441   switch (sym->u.s.redirect)
  3442     {
  3443     case SYMBOL_PLAINVAL:
  3444       if (!sym->u.s.trapped_write)
  3445         SET_SYMBOL_VAL (sym, value);
  3446       else
  3447         set_internal (specpdl_symbol (bind), value, Qnil, bindflag);
  3448       break;
  3449 
  3450     case SYMBOL_FORWARDED:
  3451       if (BUFFER_OBJFWDP (SYMBOL_FWD (sym))
  3452           && specpdl_kind (bind) == SPECPDL_LET_DEFAULT)
  3453         {
  3454           set_default_internal (specpdl_symbol (bind), value, bindflag);
  3455           return;
  3456         }
  3457       FALLTHROUGH;
  3458     case SYMBOL_LOCALIZED:
  3459       set_internal (specpdl_symbol (bind), value, Qnil, bindflag);
  3460       break;
  3461 
  3462     default:
  3463       emacs_abort ();
  3464     }
  3465 }
  3466 
  3467 /* `specpdl_ptr' describes which variable is
  3468    let-bound, so it can be properly undone when we unbind_to.
  3469    It can be either a plain SPECPDL_LET or a SPECPDL_LET_LOCAL/DEFAULT.
  3470    - SYMBOL is the variable being bound.  Note that it should not be
  3471      aliased (i.e. when let-binding V1 that's aliased to V2, we want
  3472      to record V2 here).
  3473    - WHERE tells us in which buffer the binding took place.
  3474      This is used for SPECPDL_LET_LOCAL bindings (i.e. bindings to a
  3475      buffer-local variable) as well as for SPECPDL_LET_DEFAULT bindings,
  3476      i.e. bindings to the default value of a variable which can be
  3477      buffer-local.  */
  3478 
  3479 void
  3480 specbind (Lisp_Object symbol, Lisp_Object value)
  3481 {
  3482   struct Lisp_Symbol *sym;
  3483 
  3484   CHECK_SYMBOL (symbol);
  3485   sym = XSYMBOL (symbol);
  3486 
  3487  start:
  3488   switch (sym->u.s.redirect)
  3489     {
  3490     case SYMBOL_VARALIAS:
  3491       sym = SYMBOL_ALIAS (sym); XSETSYMBOL (symbol, sym); goto start;
  3492     case SYMBOL_PLAINVAL:
  3493       /* The most common case is that of a non-constant symbol with a
  3494          trivial value.  Make that as fast as we can.  */
  3495       specpdl_ptr->let.kind = SPECPDL_LET;
  3496       specpdl_ptr->let.symbol = symbol;
  3497       specpdl_ptr->let.old_value = SYMBOL_VAL (sym);
  3498       break;
  3499     case SYMBOL_LOCALIZED:
  3500     case SYMBOL_FORWARDED:
  3501       {
  3502         Lisp_Object ovalue = find_symbol_value (symbol);
  3503         specpdl_ptr->let.kind = SPECPDL_LET_LOCAL;
  3504         specpdl_ptr->let.symbol = symbol;
  3505         specpdl_ptr->let.old_value = ovalue;
  3506         specpdl_ptr->let.where = Fcurrent_buffer ();
  3507 
  3508         eassert (sym->u.s.redirect != SYMBOL_LOCALIZED
  3509                  || (BASE_EQ (SYMBOL_BLV (sym)->where, Fcurrent_buffer ())));
  3510 
  3511         if (sym->u.s.redirect == SYMBOL_LOCALIZED)
  3512           {
  3513             if (!blv_found (SYMBOL_BLV (sym)))
  3514               specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
  3515           }
  3516         else if (BUFFER_OBJFWDP (SYMBOL_FWD (sym)))
  3517           {
  3518             /* If SYMBOL is a per-buffer variable which doesn't have a
  3519                buffer-local value here, make the `let' change the global
  3520                value by changing the value of SYMBOL in all buffers not
  3521                having their own value.  This is consistent with what
  3522                happens with other buffer-local variables.  */
  3523             if (NILP (Flocal_variable_p (symbol, Qnil)))
  3524               specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
  3525           }
  3526         else
  3527           specpdl_ptr->let.kind = SPECPDL_LET;
  3528 
  3529         break;
  3530       }
  3531     default: emacs_abort ();
  3532     }
  3533   grow_specpdl ();
  3534   do_specbind (sym, specpdl_ptr - 1, value, SET_INTERNAL_BIND);
  3535 }
  3536 
  3537 /* Push unwind-protect entries of various types.  */
  3538 
  3539 void
  3540 record_unwind_protect (void (*function) (Lisp_Object), Lisp_Object arg)
  3541 {
  3542   specpdl_ptr->unwind.kind = SPECPDL_UNWIND;
  3543   specpdl_ptr->unwind.func = function;
  3544   specpdl_ptr->unwind.arg = arg;
  3545   specpdl_ptr->unwind.eval_depth = lisp_eval_depth;
  3546   grow_specpdl ();
  3547 }
  3548 
  3549 void
  3550 record_unwind_protect_array (Lisp_Object *array, ptrdiff_t nelts)
  3551 {
  3552   specpdl_ptr->unwind_array.kind = SPECPDL_UNWIND_ARRAY;
  3553   specpdl_ptr->unwind_array.array = array;
  3554   specpdl_ptr->unwind_array.nelts = nelts;
  3555   grow_specpdl ();
  3556 }
  3557 
  3558 void
  3559 record_unwind_protect_ptr (void (*function) (void *), void *arg)
  3560 {
  3561   specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
  3562   specpdl_ptr->unwind_ptr.func = function;
  3563   specpdl_ptr->unwind_ptr.arg = arg;
  3564   specpdl_ptr->unwind_ptr.mark = NULL;
  3565   grow_specpdl ();
  3566 }
  3567 
  3568 /* Like `record_unwind_protect_ptr', but also specifies a function
  3569    for GC-marking Lisp objects only reachable through ARG.  */
  3570 void
  3571 record_unwind_protect_ptr_mark (void (*function) (void *), void *arg,
  3572                                 void (*mark) (void *))
  3573 {
  3574   specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
  3575   specpdl_ptr->unwind_ptr.func = function;
  3576   specpdl_ptr->unwind_ptr.arg = arg;
  3577   specpdl_ptr->unwind_ptr.mark = mark;
  3578   grow_specpdl ();
  3579 }
  3580 
  3581 void
  3582 record_unwind_protect_int (void (*function) (int), int arg)
  3583 {
  3584   specpdl_ptr->unwind_int.kind = SPECPDL_UNWIND_INT;
  3585   specpdl_ptr->unwind_int.func = function;
  3586   specpdl_ptr->unwind_int.arg = arg;
  3587   grow_specpdl ();
  3588 }
  3589 
  3590 void
  3591 record_unwind_protect_intmax (void (*function) (intmax_t), intmax_t arg)
  3592 {
  3593   specpdl_ptr->unwind_intmax.kind = SPECPDL_UNWIND_INTMAX;
  3594   specpdl_ptr->unwind_intmax.func = function;
  3595   specpdl_ptr->unwind_intmax.arg = arg;
  3596   grow_specpdl ();
  3597 }
  3598 
  3599 void
  3600 record_unwind_protect_excursion (void)
  3601 {
  3602   specpdl_ptr->unwind_excursion.kind = SPECPDL_UNWIND_EXCURSION;
  3603   save_excursion_save (specpdl_ptr);
  3604   grow_specpdl ();
  3605 }
  3606 
  3607 void
  3608 record_unwind_protect_void (void (*function) (void))
  3609 {
  3610   specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID;
  3611   specpdl_ptr->unwind_void.func = function;
  3612   grow_specpdl ();
  3613 }
  3614 
  3615 void
  3616 record_unwind_protect_module (enum specbind_tag kind, void *ptr)
  3617 {
  3618   specpdl_ptr->kind = kind;
  3619   specpdl_ptr->unwind_ptr.func = NULL;
  3620   specpdl_ptr->unwind_ptr.arg = ptr;
  3621   specpdl_ptr->unwind_ptr.mark = NULL;
  3622   grow_specpdl ();
  3623 }
  3624 
  3625 static void
  3626 do_one_unbind (union specbinding *this_binding, bool unwinding,
  3627                enum Set_Internal_Bind bindflag)
  3628 {
  3629   eassert (unwinding || this_binding->kind >= SPECPDL_LET);
  3630   switch (this_binding->kind)
  3631     {
  3632     case SPECPDL_UNWIND:
  3633       lisp_eval_depth = this_binding->unwind.eval_depth;
  3634       this_binding->unwind.func (this_binding->unwind.arg);
  3635       break;
  3636     case SPECPDL_UNWIND_ARRAY:
  3637       xfree (this_binding->unwind_array.array);
  3638       break;
  3639     case SPECPDL_UNWIND_PTR:
  3640       this_binding->unwind_ptr.func (this_binding->unwind_ptr.arg);
  3641       break;
  3642     case SPECPDL_UNWIND_INT:
  3643       this_binding->unwind_int.func (this_binding->unwind_int.arg);
  3644       break;
  3645     case SPECPDL_UNWIND_INTMAX:
  3646       this_binding->unwind_intmax.func (this_binding->unwind_intmax.arg);
  3647       break;
  3648     case SPECPDL_UNWIND_VOID:
  3649       this_binding->unwind_void.func ();
  3650       break;
  3651     case SPECPDL_UNWIND_EXCURSION:
  3652       save_excursion_restore (this_binding->unwind_excursion.marker,
  3653                               this_binding->unwind_excursion.window);
  3654       break;
  3655     case SPECPDL_BACKTRACE:
  3656     case SPECPDL_NOP:
  3657       break;
  3658 #ifdef HAVE_MODULES
  3659     case SPECPDL_MODULE_RUNTIME:
  3660       finalize_runtime_unwind (this_binding->unwind_ptr.arg);
  3661       break;
  3662     case SPECPDL_MODULE_ENVIRONMENT:
  3663       finalize_environment_unwind (this_binding->unwind_ptr.arg);
  3664       break;
  3665 #endif
  3666     case SPECPDL_LET:
  3667       { /* If variable has a trivial value (no forwarding), and isn't
  3668            trapped, we can just set it.  */
  3669         Lisp_Object sym = specpdl_symbol (this_binding);
  3670         if (SYMBOLP (sym) && XSYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL)
  3671           {
  3672             if (XSYMBOL (sym)->u.s.trapped_write == SYMBOL_UNTRAPPED_WRITE)
  3673               SET_SYMBOL_VAL (XSYMBOL (sym), specpdl_old_value (this_binding));
  3674             else
  3675               set_internal (sym, specpdl_old_value (this_binding),
  3676                             Qnil, bindflag);
  3677             break;
  3678           }
  3679       }
  3680       /* Come here only if make_local_foo was used for the first time
  3681          on this var within this let.  */
  3682       FALLTHROUGH;
  3683     case SPECPDL_LET_DEFAULT:
  3684       set_default_internal (specpdl_symbol (this_binding),
  3685                             specpdl_old_value (this_binding),
  3686                             bindflag);
  3687       break;
  3688     case SPECPDL_LET_LOCAL:
  3689       {
  3690         Lisp_Object symbol = specpdl_symbol (this_binding);
  3691         Lisp_Object where = specpdl_where (this_binding);
  3692         Lisp_Object old_value = specpdl_old_value (this_binding);
  3693         eassert (BUFFERP (where));
  3694 
  3695         /* If this was a local binding, reset the value in the appropriate
  3696            buffer, but only if that buffer's binding still exists.  */
  3697         if (!NILP (Flocal_variable_p (symbol, where)))
  3698           set_internal (symbol, old_value, where, bindflag);
  3699       }
  3700       break;
  3701     }
  3702 }
  3703 
  3704 static void
  3705 do_nothing (void)
  3706 {}
  3707 
  3708 /* Push an unwind-protect entry that does nothing, so that
  3709    set_unwind_protect_ptr can overwrite it later.  */
  3710 
  3711 void
  3712 record_unwind_protect_nothing (void)
  3713 {
  3714   record_unwind_protect_void (do_nothing);
  3715 }
  3716 
  3717 /* Clear the unwind-protect entry COUNT, so that it does nothing.
  3718    It need not be at the top of the stack.  */
  3719 
  3720 void
  3721 clear_unwind_protect (specpdl_ref count)
  3722 {
  3723   union specbinding *p = specpdl_ref_to_ptr (count);
  3724   p->unwind_void.kind = SPECPDL_UNWIND_VOID;
  3725   p->unwind_void.func = do_nothing;
  3726 }
  3727 
  3728 /* Set the unwind-protect entry COUNT so that it invokes FUNC (ARG).
  3729    It need not be at the top of the stack.  Discard the entry's
  3730    previous value without invoking it.  */
  3731 
  3732 void
  3733 set_unwind_protect (specpdl_ref count, void (*func) (Lisp_Object),
  3734                     Lisp_Object arg)
  3735 {
  3736   union specbinding *p = specpdl_ref_to_ptr (count);
  3737   p->unwind.kind = SPECPDL_UNWIND;
  3738   p->unwind.func = func;
  3739   p->unwind.arg = arg;
  3740   p->unwind.eval_depth = lisp_eval_depth;
  3741 }
  3742 
  3743 void
  3744 set_unwind_protect_ptr (specpdl_ref count, void (*func) (void *), void *arg)
  3745 {
  3746   union specbinding *p = specpdl_ref_to_ptr (count);
  3747   p->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
  3748   p->unwind_ptr.func = func;
  3749   p->unwind_ptr.arg = arg;
  3750   p->unwind_ptr.mark = NULL;
  3751 }
  3752 
  3753 /* Pop and execute entries from the unwind-protect stack until the
  3754    depth COUNT is reached.  Return VALUE.  */
  3755 
  3756 Lisp_Object
  3757 unbind_to (specpdl_ref count, Lisp_Object value)
  3758 {
  3759   Lisp_Object quitf = Vquit_flag;
  3760 
  3761   Vquit_flag = Qnil;
  3762 
  3763   while (specpdl_ptr != specpdl_ref_to_ptr (count))
  3764     {
  3765       /* Copy the binding, and decrement specpdl_ptr, before we do
  3766          the work to unbind it.  We decrement first
  3767          so that an error in unbinding won't try to unbind
  3768          the same entry again, and we copy the binding first
  3769          in case more bindings are made during some of the code we run.  */
  3770 
  3771       union specbinding this_binding;
  3772       this_binding = *--specpdl_ptr;
  3773 
  3774       do_one_unbind (&this_binding, true, SET_INTERNAL_UNBIND);
  3775     }
  3776 
  3777   if (NILP (Vquit_flag) && !NILP (quitf))
  3778     Vquit_flag = quitf;
  3779 
  3780   return value;
  3781 }
  3782 
  3783 DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
  3784        doc: /* Return non-nil if SYMBOL's global binding has been declared special.
  3785 A special variable is one that will be bound dynamically, even in a
  3786 context where binding is lexical by default.  */)
  3787   (Lisp_Object symbol)
  3788 {
  3789    CHECK_SYMBOL (symbol);
  3790    return XSYMBOL (symbol)->u.s.declared_special ? Qt : Qnil;
  3791 }
  3792 
  3793 
  3794 static union specbinding *
  3795 get_backtrace_starting_at (Lisp_Object base)
  3796 {
  3797   union specbinding *pdl = backtrace_top ();
  3798 
  3799   if (!NILP (base))
  3800     { /* Skip up to `base'.  */
  3801       base = Findirect_function (base, Qt);
  3802       while (backtrace_p (pdl)
  3803              && !EQ (base, Findirect_function (backtrace_function (pdl), Qt)))
  3804         pdl = backtrace_next (pdl);
  3805     }
  3806 
  3807   return pdl;
  3808 }
  3809 
  3810 static union specbinding *
  3811 get_backtrace_frame (Lisp_Object nframes, Lisp_Object base)
  3812 {
  3813   register EMACS_INT i;
  3814 
  3815   CHECK_FIXNAT (nframes);
  3816   union specbinding *pdl = get_backtrace_starting_at (base);
  3817 
  3818   /* Find the frame requested.  */
  3819   for (i = XFIXNAT (nframes); i > 0 && backtrace_p (pdl); i--)
  3820     pdl = backtrace_next (pdl);
  3821 
  3822   return pdl;
  3823 }
  3824 
  3825 static Lisp_Object
  3826 backtrace_frame_apply (Lisp_Object function, union specbinding *pdl)
  3827 {
  3828   if (!backtrace_p (pdl))
  3829     return Qnil;
  3830 
  3831   Lisp_Object flags = Qnil;
  3832   if (backtrace_debug_on_exit (pdl))
  3833     flags = list2 (QCdebug_on_exit, Qt);
  3834 
  3835   if (backtrace_nargs (pdl) == UNEVALLED)
  3836     return call4 (function, Qnil, backtrace_function (pdl), *backtrace_args (pdl), flags);
  3837   else
  3838     {
  3839       Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
  3840       return call4 (function, Qt, backtrace_function (pdl), tem, flags);
  3841     }
  3842 }
  3843 
  3844 DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
  3845        doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
  3846 The debugger is entered when that frame exits, if the flag is non-nil.  */)
  3847   (Lisp_Object level, Lisp_Object flag)
  3848 {
  3849   CHECK_FIXNUM (level);
  3850   union specbinding *pdl = get_backtrace_frame(level, Qnil);
  3851 
  3852   if (backtrace_p (pdl))
  3853     set_backtrace_debug_on_exit (pdl, !NILP (flag));
  3854 
  3855   return flag;
  3856 }
  3857 
  3858 DEFUN ("mapbacktrace", Fmapbacktrace, Smapbacktrace, 1, 2, 0,
  3859        doc: /* Call FUNCTION for each frame in backtrace.
  3860 If BASE is non-nil, it should be a function and iteration will start
  3861 from its nearest activation frame.
  3862 FUNCTION is called with 4 arguments: EVALD, FUNC, ARGS, and FLAGS.  If
  3863 a frame has not evaluated its arguments yet or is a special form,
  3864 EVALD is nil and ARGS is a list of forms.  If a frame has evaluated
  3865 its arguments and called its function already, EVALD is t and ARGS is
  3866 a list of values.
  3867 FLAGS is a plist of properties of the current frame: currently, the
  3868 only supported property is :debug-on-exit.  `mapbacktrace' always
  3869 returns nil.  */)
  3870      (Lisp_Object function, Lisp_Object base)
  3871 {
  3872   union specbinding *pdl = get_backtrace_starting_at (base);
  3873 
  3874   while (backtrace_p (pdl))
  3875     {
  3876       ptrdiff_t i = pdl - specpdl;
  3877       backtrace_frame_apply (function, pdl);
  3878       /* Beware! PDL is no longer valid here because FUNCTION might
  3879          have caused grow_specpdl to reallocate pdlvec.  We must use
  3880          the saved index, cf. Bug#27258.  */
  3881       pdl = backtrace_next (&specpdl[i]);
  3882     }
  3883 
  3884   return Qnil;
  3885 }
  3886 
  3887 DEFUN ("backtrace-frame--internal", Fbacktrace_frame_internal,
  3888        Sbacktrace_frame_internal, 3, 3, NULL,
  3889        doc: /* Call FUNCTION on stack frame NFRAMES away from BASE.
  3890 Return the result of FUNCTION, or nil if no matching frame could be found. */)
  3891      (Lisp_Object function, Lisp_Object nframes, Lisp_Object base)
  3892 {
  3893   return backtrace_frame_apply (function, get_backtrace_frame (nframes, base));
  3894 }
  3895 
  3896 DEFUN ("backtrace--frames-from-thread", Fbacktrace_frames_from_thread,
  3897        Sbacktrace_frames_from_thread, 1, 1, NULL,
  3898        doc: /* Return the list of backtrace frames from current execution point in THREAD.
  3899 If a frame has not evaluated the arguments yet (or is a special form),
  3900 the value of the list element is (nil FUNCTION ARG-FORMS...).
  3901 If a frame has evaluated its arguments and called its function already,
  3902 the value of the list element is (t FUNCTION ARG-VALUES...).
  3903 A &rest arg is represented as the tail of the list ARG-VALUES.
  3904 FUNCTION is whatever was supplied as car of evaluated list,
  3905 or a lambda expression for macro calls.  */)
  3906      (Lisp_Object thread)
  3907 {
  3908   struct thread_state *tstate;
  3909   CHECK_THREAD (thread);
  3910   tstate = XTHREAD (thread);
  3911 
  3912   union specbinding *pdl = backtrace_thread_top (tstate);
  3913   Lisp_Object list = Qnil;
  3914 
  3915   while (backtrace_thread_p (tstate, pdl))
  3916     {
  3917       Lisp_Object frame;
  3918       if (backtrace_nargs (pdl) == UNEVALLED)
  3919         frame = Fcons (Qnil,
  3920                       Fcons (backtrace_function (pdl), *backtrace_args (pdl)));
  3921       else
  3922         {
  3923           Lisp_Object tem = Flist (backtrace_nargs (pdl), backtrace_args (pdl));
  3924           frame = Fcons (Qt, Fcons (backtrace_function (pdl), tem));
  3925         }
  3926       list = Fcons (frame, list);
  3927       pdl = backtrace_thread_next (tstate, pdl);
  3928     }
  3929   return Fnreverse (list);
  3930 }
  3931 
  3932 /* For backtrace-eval, we want to temporarily unwind the last few elements of
  3933    the specpdl stack, and then rewind them.  We store the pre-unwind values
  3934    directly in the pre-existing specpdl elements (i.e. we swap the current
  3935    value and the old value stored in the specpdl), kind of like the inplace
  3936    pointer-reversal trick.  As it turns out, the rewind does the same as the
  3937    unwind, except it starts from the other end of the specpdl stack, so we use
  3938    the same function for both unwind and rewind.
  3939    This same code is used when switching threads, except in that case
  3940    we unwind/rewind the whole specpdl of the threads.  */
  3941 void
  3942 specpdl_unrewind (union specbinding *pdl, int distance, bool vars_only)
  3943 {
  3944   union specbinding *tmp = pdl;
  3945   int step = -1;
  3946   if (distance < 0)
  3947     { /* It's a rewind rather than unwind.  */
  3948       tmp += distance - 1;
  3949       step = 1;
  3950       distance = -distance;
  3951     }
  3952 
  3953   for (; distance > 0; distance--)
  3954     {
  3955       tmp += step;
  3956       switch (tmp->kind)
  3957         {
  3958           /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
  3959              unwind_protect, but the problem is that we don't know how to
  3960              rewind them afterwards.  */
  3961         case SPECPDL_UNWIND:
  3962           if (vars_only)
  3963             break;
  3964           if (tmp->unwind.func == set_buffer_if_live)
  3965             {
  3966               Lisp_Object oldarg = tmp->unwind.arg;
  3967               tmp->unwind.arg = Fcurrent_buffer ();
  3968               set_buffer_if_live (oldarg);
  3969             }
  3970           break;
  3971         case SPECPDL_UNWIND_EXCURSION:
  3972           if (vars_only)
  3973             break;
  3974           {
  3975             Lisp_Object marker = tmp->unwind_excursion.marker;
  3976             Lisp_Object window = tmp->unwind_excursion.window;
  3977             save_excursion_save (tmp);
  3978             save_excursion_restore (marker, window);
  3979           }
  3980           break;
  3981         case SPECPDL_LET:
  3982           { /* If variable has a trivial value (no forwarding), we can
  3983                just set it.  No need to check for constant symbols here,
  3984                since that was already done by specbind.  */
  3985             Lisp_Object sym = specpdl_symbol (tmp);
  3986             if (SYMBOLP (sym)
  3987                 && XSYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL)
  3988               {
  3989                 Lisp_Object old_value = specpdl_old_value (tmp);
  3990                 set_specpdl_old_value (tmp, SYMBOL_VAL (XSYMBOL (sym)));
  3991                 SET_SYMBOL_VAL (XSYMBOL (sym), old_value);
  3992                 break;
  3993               }
  3994           }
  3995           /* Come here only if make_local_foo was used for the first
  3996              time on this var within this let.  */
  3997           FALLTHROUGH;
  3998         case SPECPDL_LET_DEFAULT:
  3999           {
  4000             Lisp_Object sym = specpdl_symbol (tmp);
  4001             Lisp_Object old_value = specpdl_old_value (tmp);
  4002             set_specpdl_old_value (tmp, default_value (sym));
  4003             set_default_internal (sym, old_value, SET_INTERNAL_THREAD_SWITCH);
  4004           }
  4005           break;
  4006         case SPECPDL_LET_LOCAL:
  4007           {
  4008             Lisp_Object symbol = specpdl_symbol (tmp);
  4009             Lisp_Object where = specpdl_where (tmp);
  4010             Lisp_Object old_value = specpdl_old_value (tmp);
  4011             eassert (BUFFERP (where));
  4012 
  4013             /* If this was a local binding, reset the value in the appropriate
  4014                buffer, but only if that buffer's binding still exists.  */
  4015             if (!NILP (Flocal_variable_p (symbol, where)))
  4016               {
  4017                 set_specpdl_old_value
  4018                   (tmp, buffer_local_value (symbol, where));
  4019                 set_internal (symbol, old_value, where,
  4020                               SET_INTERNAL_THREAD_SWITCH);
  4021               }
  4022             else
  4023               /* If the var is not local any more, it can't be undone nor
  4024                  redone, so just zap it.
  4025                  This is important in case the buffer re-gains a local value
  4026                  before we unrewind again, in which case we'd risk applying
  4027                  this entry in the wrong direction.  */
  4028               tmp->kind = SPECPDL_NOP;
  4029           }
  4030           break;
  4031 
  4032         default: break;
  4033         }
  4034     }
  4035 }
  4036 
  4037 static void
  4038 backtrace_eval_unrewind (int distance)
  4039 {
  4040   specpdl_unrewind (specpdl_ptr, distance, false);
  4041 }
  4042 
  4043 DEFUN ("backtrace-eval", Fbacktrace_eval, Sbacktrace_eval, 2, 3, NULL,
  4044        doc: /* Evaluate EXP in the context of some activation frame.
  4045 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.  */)
  4046      (Lisp_Object exp, Lisp_Object nframes, Lisp_Object base)
  4047 {
  4048   union specbinding *pdl = get_backtrace_frame (nframes, base);
  4049   specpdl_ref count = SPECPDL_INDEX ();
  4050   ptrdiff_t distance = specpdl_ptr - pdl;
  4051   eassert (distance >= 0);
  4052 
  4053   if (!backtrace_p (pdl))
  4054     error ("Activation frame not found!");
  4055 
  4056   backtrace_eval_unrewind (distance);
  4057   record_unwind_protect_int (backtrace_eval_unrewind, -distance);
  4058 
  4059   /* Use eval_sub rather than Feval since the main motivation behind
  4060      backtrace-eval is to be able to get/set the value of lexical variables
  4061      from the debugger.  */
  4062   return unbind_to (count, eval_sub (exp));
  4063 }
  4064 
  4065 DEFUN ("backtrace--locals", Fbacktrace__locals, Sbacktrace__locals, 1, 2, NULL,
  4066        doc: /* Return names and values of local variables of a stack frame.
  4067 NFRAMES and BASE specify the activation frame to use, as in `backtrace-frame'.  */)
  4068   (Lisp_Object nframes, Lisp_Object base)
  4069 {
  4070   union specbinding *frame = get_backtrace_frame (nframes, base);
  4071   union specbinding *prevframe
  4072     = get_backtrace_frame (make_fixnum (XFIXNAT (nframes) - 1), base);
  4073   ptrdiff_t distance = specpdl_ptr - frame;
  4074   Lisp_Object result = Qnil;
  4075   eassert (distance >= 0);
  4076 
  4077   if (!backtrace_p (prevframe))
  4078     error ("Activation frame not found!");
  4079   if (!backtrace_p (frame))
  4080     error ("Activation frame not found!");
  4081 
  4082   /* The specpdl entries normally contain the symbol being bound along with its
  4083      `old_value', so it can be restored.  The new value to which it is bound is
  4084      available in one of two places: either in the current value of the
  4085      variable (if it hasn't been rebound yet) or in the `old_value' slot of the
  4086      next specpdl entry for it.
  4087      `backtrace_eval_unrewind' happens to swap the role of `old_value'
  4088      and "new value", so we abuse it here, to fetch the new value.
  4089      It's ugly (we'd rather not modify global data) and a bit inefficient,
  4090      but it does the job for now.  */
  4091   backtrace_eval_unrewind (distance);
  4092 
  4093   /* Grab values.  */
  4094   {
  4095     union specbinding *tmp = prevframe;
  4096     for (; tmp > frame; tmp--)
  4097       {
  4098         switch (tmp->kind)
  4099           {
  4100           case SPECPDL_LET:
  4101           case SPECPDL_LET_DEFAULT:
  4102           case SPECPDL_LET_LOCAL:
  4103             {
  4104               Lisp_Object sym = specpdl_symbol (tmp);
  4105               Lisp_Object val = specpdl_old_value (tmp);
  4106               if (EQ (sym, Qinternal_interpreter_environment))
  4107                 {
  4108                   Lisp_Object env = val;
  4109                   for (; CONSP (env); env = XCDR (env))
  4110                     {
  4111                       Lisp_Object binding = XCAR (env);
  4112                       if (CONSP (binding))
  4113                         result = Fcons (Fcons (XCAR (binding),
  4114                                                XCDR (binding)),
  4115                                         result);
  4116                     }
  4117                 }
  4118               else
  4119                 result = Fcons (Fcons (sym, val), result);
  4120             }
  4121             break;
  4122 
  4123           default: break;
  4124           }
  4125       }
  4126   }
  4127 
  4128   /* Restore values from specpdl to original place.  */
  4129   backtrace_eval_unrewind (-distance);
  4130 
  4131   return result;
  4132 }
  4133 
  4134 
  4135 void
  4136 mark_specpdl (union specbinding *first, union specbinding *ptr)
  4137 {
  4138   union specbinding *pdl;
  4139   for (pdl = first; pdl != ptr; pdl++)
  4140     {
  4141       switch (pdl->kind)
  4142         {
  4143         case SPECPDL_UNWIND:
  4144           mark_object (specpdl_arg (pdl));
  4145           break;
  4146 
  4147         case SPECPDL_UNWIND_ARRAY:
  4148           mark_objects (pdl->unwind_array.array, pdl->unwind_array.nelts);
  4149           break;
  4150 
  4151         case SPECPDL_UNWIND_EXCURSION:
  4152           mark_object (pdl->unwind_excursion.marker);
  4153           mark_object (pdl->unwind_excursion.window);
  4154           break;
  4155 
  4156         case SPECPDL_BACKTRACE:
  4157           {
  4158             ptrdiff_t nargs = backtrace_nargs (pdl);
  4159             mark_object (backtrace_function (pdl));
  4160             if (nargs == UNEVALLED)
  4161               nargs = 1;
  4162             mark_objects (backtrace_args (pdl), nargs);
  4163           }
  4164           break;
  4165 
  4166 #ifdef HAVE_MODULES
  4167         case SPECPDL_MODULE_RUNTIME:
  4168           break;
  4169         case SPECPDL_MODULE_ENVIRONMENT:
  4170           mark_module_environment (pdl->unwind_ptr.arg);
  4171           break;
  4172 #endif
  4173 
  4174         case SPECPDL_LET_DEFAULT:
  4175         case SPECPDL_LET_LOCAL:
  4176           mark_object (specpdl_where (pdl));
  4177           FALLTHROUGH;
  4178         case SPECPDL_LET:
  4179           mark_object (specpdl_symbol (pdl));
  4180           mark_object (specpdl_old_value (pdl));
  4181           break;
  4182 
  4183         case SPECPDL_UNWIND_PTR:
  4184           if (pdl->unwind_ptr.mark)
  4185             pdl->unwind_ptr.mark (pdl->unwind_ptr.arg);
  4186           break;
  4187 
  4188         case SPECPDL_UNWIND_INT:
  4189         case SPECPDL_UNWIND_INTMAX:
  4190         case SPECPDL_UNWIND_VOID:
  4191         case SPECPDL_NOP:
  4192           break;
  4193 
  4194         /* While other loops that scan the specpdl use "default: break;"
  4195            for simplicity, here we explicitly list all cases and abort
  4196            if we find an unexpected value, as a sanity check.  */
  4197         default:
  4198           emacs_abort ();
  4199         }
  4200     }
  4201 }
  4202 
  4203 void
  4204 get_backtrace (Lisp_Object array)
  4205 {
  4206   union specbinding *pdl = backtrace_top ();
  4207   ptrdiff_t i = 0, asize = ASIZE (array);
  4208 
  4209   /* Copy the backtrace contents into working memory.  */
  4210   for (; i < asize; i++)
  4211     {
  4212       if (backtrace_p (pdl))
  4213         {
  4214           ASET (array, i, backtrace_function (pdl));
  4215           pdl = backtrace_next (pdl);
  4216         }
  4217       else
  4218         ASET (array, i, Qnil);
  4219     }
  4220 }
  4221 
  4222 Lisp_Object backtrace_top_function (void)
  4223 {
  4224   union specbinding *pdl = backtrace_top ();
  4225   return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
  4226 }
  4227 
  4228 void
  4229 syms_of_eval (void)
  4230 {
  4231   DEFVAR_INT ("max-lisp-eval-depth", max_lisp_eval_depth,
  4232               doc: /* Limit on depth in `eval', `apply' and `funcall' before error.
  4233 
  4234 This limit serves to catch infinite recursions for you before they cause
  4235 actual stack overflow in C, which would be fatal for Emacs.
  4236 You can safely make it considerably larger than its default value,
  4237 if that proves inconveniently small.  However, if you increase it too far,
  4238 Emacs could overflow the real C stack, and crash.  */);
  4239 
  4240   DEFVAR_LISP ("quit-flag", Vquit_flag,
  4241                doc: /* Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.
  4242 If the value is t, that means do an ordinary quit.
  4243 If the value equals `throw-on-input', that means quit by throwing
  4244 to the tag specified in `throw-on-input'; it's for handling `while-no-input'.
  4245 Typing C-g sets `quit-flag' to t, regardless of `inhibit-quit',
  4246 but `inhibit-quit' non-nil prevents anything from taking notice of that.  */);
  4247   Vquit_flag = Qnil;
  4248 
  4249   DEFVAR_LISP ("inhibit-quit", Vinhibit_quit,
  4250                doc: /* Non-nil inhibits C-g quitting from happening immediately.
  4251 Note that `quit-flag' will still be set by typing C-g,
  4252 so a quit will be signaled as soon as `inhibit-quit' is nil.
  4253 To prevent this happening, set `quit-flag' to nil
  4254 before making `inhibit-quit' nil.  */);
  4255   Vinhibit_quit = Qnil;
  4256 
  4257   DEFSYM (Qsetq, "setq");
  4258   DEFSYM (Qinhibit_quit, "inhibit-quit");
  4259   DEFSYM (Qautoload, "autoload");
  4260   DEFSYM (Qinhibit_debugger, "inhibit-debugger");
  4261   DEFSYM (Qmacro, "macro");
  4262 
  4263   /* Note that the process handling also uses Qexit, but we don't want
  4264      to staticpro it twice, so we just do it here.  */
  4265   DEFSYM (Qexit, "exit");
  4266 
  4267   DEFSYM (Qinteractive, "interactive");
  4268   DEFSYM (Qcommandp, "commandp");
  4269   DEFSYM (Qand_rest, "&rest");
  4270   DEFSYM (Qand_optional, "&optional");
  4271   DEFSYM (Qclosure, "closure");
  4272   DEFSYM (QCdocumentation, ":documentation");
  4273   DEFSYM (Qdebug, "debug");
  4274   DEFSYM (Qdebug_early, "debug-early");
  4275 
  4276   DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger,
  4277                doc: /* Non-nil means never enter the debugger.
  4278 Normally set while the debugger is already active, to avoid recursive
  4279 invocations.  */);
  4280   Vinhibit_debugger = Qnil;
  4281 
  4282   DEFVAR_LISP ("debug-on-error", Vdebug_on_error,
  4283                doc: /* Non-nil means enter debugger if an error is signaled.
  4284 Does not apply to errors handled by `condition-case' or those
  4285 matched by `debug-ignored-errors'.
  4286 If the value is a list, an error only means to enter the debugger
  4287 if one of its condition symbols appears in the list.
  4288 When you evaluate an expression interactively, this variable
  4289 is temporarily non-nil if `eval-expression-debug-on-error' is non-nil.
  4290 The command `toggle-debug-on-error' toggles this.
  4291 See also the variable `debug-on-quit' and `inhibit-debugger'.  */);
  4292   Vdebug_on_error = Qnil;
  4293 
  4294   DEFVAR_LISP ("debug-ignored-errors", Vdebug_ignored_errors,
  4295     doc: /* List of errors for which the debugger should not be called.
  4296 Each element may be a condition-name or a regexp that matches error messages.
  4297 If any element applies to a given error, that error skips the debugger
  4298 and just returns to top level.
  4299 This overrides the variable `debug-on-error'.
  4300 It does not apply to errors handled by `condition-case'.  */);
  4301   Vdebug_ignored_errors = Qnil;
  4302 
  4303   DEFVAR_BOOL ("debug-on-quit", debug_on_quit,
  4304     doc: /* Non-nil means enter debugger if quit is signaled (C-g, for example).
  4305 Does not apply if quit is handled by a `condition-case'.  */);
  4306   debug_on_quit = 0;
  4307 
  4308   DEFVAR_BOOL ("debug-on-next-call", debug_on_next_call,
  4309                doc: /* Non-nil means enter debugger before next `eval', `apply' or `funcall'.  */);
  4310 
  4311   DEFVAR_BOOL ("backtrace-on-redisplay-error", backtrace_on_redisplay_error,
  4312                doc: /* Non-nil means create a backtrace if a lisp error occurs in redisplay.
  4313 The backtrace is written to buffer *Redisplay-trace*.  */);
  4314   backtrace_on_redisplay_error = false;
  4315 
  4316   DEFVAR_BOOL ("debugger-may-continue", debugger_may_continue,
  4317                doc: /* Non-nil means debugger may continue execution.
  4318 This is nil when the debugger is called under circumstances where it
  4319 might not be safe to continue.  */);
  4320   debugger_may_continue = 1;
  4321 
  4322   DEFVAR_BOOL ("debugger-stack-frame-as-list", debugger_stack_frame_as_list,
  4323                doc: /* Non-nil means display call stack frames as lists. */);
  4324   debugger_stack_frame_as_list = 0;
  4325 
  4326   DEFSYM (Qdebugger, "debugger");
  4327   DEFVAR_LISP ("debugger", Vdebugger,
  4328                doc: /* Function to call to invoke debugger.
  4329 If due to frame exit, args are `exit' and the value being returned;
  4330  this function's value will be returned instead of that.
  4331 If due to error, args are `error' and a list of the args to `signal'.
  4332 If due to `apply' or `funcall' entry, one arg, `lambda'.
  4333 If due to `eval' entry, one arg, t.  */);
  4334   Vdebugger = Qdebug_early;
  4335 
  4336   DEFVAR_LISP ("signal-hook-function", Vsignal_hook_function,
  4337                doc: /* If non-nil, this is a function for `signal' to call.
  4338 It receives the same arguments that `signal' was given.
  4339 The Edebug package uses this to regain control.  */);
  4340   Vsignal_hook_function = Qnil;
  4341 
  4342   DEFVAR_LISP ("debug-on-signal", Vdebug_on_signal,
  4343                doc: /* Non-nil means call the debugger regardless of condition handlers.
  4344 Note that `debug-on-error', `debug-on-quit' and friends
  4345 still determine whether to handle the particular condition.  */);
  4346   Vdebug_on_signal = Qnil;
  4347 
  4348   DEFVAR_BOOL ("backtrace-on-error-noninteractive",
  4349                backtrace_on_error_noninteractive,
  4350                doc: /* Non-nil means print backtrace on error in batch mode.
  4351 If this is nil, errors in batch mode will just print the error
  4352 message upon encountering an unhandled error, without showing
  4353 the Lisp backtrace.  */);
  4354   backtrace_on_error_noninteractive = true;
  4355 
  4356   /* The value of num_nonmacro_input_events as of the last time we
  4357    started to enter the debugger.  If we decide to enter the debugger
  4358    again when this is still equal to num_nonmacro_input_events, then we
  4359    know that the debugger itself has an error, and we should just
  4360    signal the error instead of entering an infinite loop of debugger
  4361    invocations.  */
  4362   DEFSYM (Qinternal_when_entered_debugger, "internal-when-entered-debugger");
  4363   DEFVAR_INT ("internal-when-entered-debugger", when_entered_debugger,
  4364               doc: /* The number of keyboard events as of last time `debugger' was called.
  4365 Used to avoid infinite loops if the debugger itself has an error.
  4366 Don't set this unless you're sure that can't happen.  */);
  4367 
  4368   /* When lexical binding is being used,
  4369    Vinternal_interpreter_environment is non-nil, and contains an alist
  4370    of lexically-bound variable, or (t), indicating an empty
  4371    environment.  The lisp name of this variable would be
  4372    `internal-interpreter-environment' if it weren't hidden.
  4373    Every element of this list can be either a cons (VAR . VAL)
  4374    specifying a lexical binding, or a single symbol VAR indicating
  4375    that this variable should use dynamic scoping.  */
  4376   DEFSYM (Qinternal_interpreter_environment,
  4377           "internal-interpreter-environment");
  4378   DEFVAR_LISP ("internal-interpreter-environment",
  4379                 Vinternal_interpreter_environment,
  4380                doc: /* If non-nil, the current lexical environment of the lisp interpreter.
  4381 When lexical binding is not being used, this variable is nil.
  4382 A value of `(t)' indicates an empty environment, otherwise it is an
  4383 alist of active lexical bindings.  */);
  4384   Vinternal_interpreter_environment = Qnil;
  4385   /* Don't export this variable to Elisp, so no one can mess with it
  4386      (Just imagine if someone makes it buffer-local).  */
  4387   Funintern (Qinternal_interpreter_environment, Qnil);
  4388 
  4389   DEFVAR_LISP ("internal-make-interpreted-closure-function",
  4390                Vinternal_make_interpreted_closure_function,
  4391                doc: /* Function to filter the env when constructing a closure.  */);
  4392   Vinternal_make_interpreted_closure_function = Qnil;
  4393 
  4394   Vrun_hooks = intern_c_string ("run-hooks");
  4395   staticpro (&Vrun_hooks);
  4396 
  4397   staticpro (&Vautoload_queue);
  4398   Vautoload_queue = Qnil;
  4399   staticpro (&Vsignaling_function);
  4400   Vsignaling_function = Qnil;
  4401 
  4402   staticpro (&Qcatch_all_memory_full);
  4403   /* Make sure Qcatch_all_memory_full is a unique object.  We could
  4404      also use something like Fcons (Qnil, Qnil), but json.c treats any
  4405      cons cell as error data, so use an uninterned symbol instead.  */
  4406   Qcatch_all_memory_full
  4407     = Fmake_symbol (build_pure_c_string ("catch-all-memory-full"));
  4408 
  4409   staticpro (&list_of_t);
  4410   list_of_t = list1 (Qt);
  4411 
  4412   defsubr (&Sor);
  4413   defsubr (&Sand);
  4414   defsubr (&Sif);
  4415   defsubr (&Scond);
  4416   defsubr (&Sprogn);
  4417   defsubr (&Sprog1);
  4418   defsubr (&Ssetq);
  4419   defsubr (&Squote);
  4420   defsubr (&Sfunction);
  4421   defsubr (&Sdefault_toplevel_value);
  4422   defsubr (&Sset_default_toplevel_value);
  4423   defsubr (&Sdefvar);
  4424   defsubr (&Sdefvar_1);
  4425   defsubr (&Sdefvaralias);
  4426   DEFSYM (Qdefvaralias, "defvaralias");
  4427   defsubr (&Sdefconst);
  4428   defsubr (&Sdefconst_1);
  4429   defsubr (&Sinternal__define_uninitialized_variable);
  4430   defsubr (&Smake_var_non_special);
  4431   defsubr (&Slet);
  4432   defsubr (&SletX);
  4433   defsubr (&Swhile);
  4434   defsubr (&Sfuncall_with_delayed_message);
  4435   defsubr (&Smacroexpand);
  4436   defsubr (&Scatch);
  4437   defsubr (&Sthrow);
  4438   defsubr (&Sunwind_protect);
  4439   defsubr (&Scondition_case);
  4440   DEFSYM (QCsuccess, ":success");
  4441   defsubr (&Ssignal);
  4442   defsubr (&Scommandp);
  4443   defsubr (&Sautoload);
  4444   defsubr (&Sautoload_do_load);
  4445   defsubr (&Seval);
  4446   defsubr (&Sapply);
  4447   defsubr (&Sfuncall);
  4448   defsubr (&Sfunc_arity);
  4449   defsubr (&Srun_hooks);
  4450   defsubr (&Srun_hook_with_args);
  4451   defsubr (&Srun_hook_with_args_until_success);
  4452   defsubr (&Srun_hook_with_args_until_failure);
  4453   defsubr (&Srun_hook_wrapped);
  4454   defsubr (&Sfetch_bytecode);
  4455   defsubr (&Sbacktrace_debug);
  4456   DEFSYM (QCdebug_on_exit, ":debug-on-exit");
  4457   defsubr (&Smapbacktrace);
  4458   defsubr (&Sbacktrace_frame_internal);
  4459   defsubr (&Sbacktrace_frames_from_thread);
  4460   defsubr (&Sbacktrace_eval);
  4461   defsubr (&Sbacktrace__locals);
  4462   defsubr (&Sspecial_variable_p);
  4463   DEFSYM (Qfunctionp, "functionp");
  4464   defsubr (&Sfunctionp);
  4465 }