* eval.c (unbind_catch): Do the long-jump here. Take a VALUE
[bpt/emacs.git] / src / eval.c
1 /* Evaluator for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 1, or (at your option)
9 any later version.
10
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
19
20
21 #include "config.h"
22 #include "lisp.h"
23 #ifdef HAVE_X_WINDOWS
24 #include "xterm.h"
25 #endif
26
27 #ifndef standalone
28 #include "commands.h"
29 #include "keyboard.h"
30 #else
31 #define INTERACTIVE 1
32 #endif
33
34 #include <setjmp.h>
35
36 /* This definition is duplicated in alloc.c and keyboard.c */
37 /* Putting it in lisp.h makes cc bomb out! */
38
39 struct backtrace
40 {
41 struct backtrace *next;
42 Lisp_Object *function;
43 Lisp_Object *args; /* Points to vector of args. */
44 int nargs; /* Length of vector.
45 If nargs is UNEVALLED, args points to slot holding
46 list of unevalled args */
47 char evalargs;
48 /* Nonzero means call value of debugger when done with this operation. */
49 char debug_on_exit;
50 };
51
52 struct backtrace *backtrace_list;
53
54 /* This structure helps implement the `catch' and `throw' control
55 structure. A struct catchtag contains all the information needed
56 to restore the state of the interpreter after a non-local jump.
57
58 Handlers for error conditions (represented by `struct handler'
59 structures) just point to a catch tag to do the cleanup required
60 for their jumps.
61
62 catchtag structures are chained together in the C calling stack;
63 the `next' member points to the next outer catchtag.
64
65 A call like (throw TAG VAL) searches for a catchtag whose `tag'
66 member is TAG, and then unbinds to it. The `val' member is used to
67 hold VAL while the stack is unwound; `val' is returned as the value
68 of the catch form.
69
70 All the other members are concerned with restoring the interpreter
71 state. */
72 struct catchtag
73 {
74 Lisp_Object tag;
75 Lisp_Object val;
76 struct catchtag *next;
77 struct gcpro *gcpro;
78 jmp_buf jmp;
79 struct backtrace *backlist;
80 struct handler *handlerlist;
81 int lisp_eval_depth;
82 int pdlcount;
83 int poll_suppress_count;
84 };
85
86 struct catchtag *catchlist;
87
88 Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
89 Lisp_Object Qinhibit_quit, Vinhibit_quit, Vquit_flag;
90 Lisp_Object Qmocklisp_arguments, Vmocklisp_arguments, Qmocklisp;
91 Lisp_Object Qand_rest, Qand_optional;
92 Lisp_Object Qdebug_on_error;
93
94 Lisp_Object Vrun_hooks;
95
96 /* Non-nil means record all fset's and provide's, to be undone
97 if the file being autoloaded is not fully loaded.
98 They are recorded by being consed onto the front of Vautoload_queue:
99 (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */
100
101 Lisp_Object Vautoload_queue;
102
103 /* Current number of specbindings allocated in specpdl. */
104 int specpdl_size;
105
106 /* Pointer to beginning of specpdl. */
107 struct specbinding *specpdl;
108
109 /* Pointer to first unused element in specpdl. */
110 struct specbinding *specpdl_ptr;
111
112 /* Maximum size allowed for specpdl allocation */
113 int max_specpdl_size;
114
115 /* Depth in Lisp evaluations and function calls. */
116 int lisp_eval_depth;
117
118 /* Maximum allowed depth in Lisp evaluations and function calls. */
119 int max_lisp_eval_depth;
120
121 /* Nonzero means enter debugger before next function call */
122 int debug_on_next_call;
123
124 /* List of conditions (non-nil atom means all) which cause a backtrace
125 if an error is handled by the command loop's error handler. */
126 Lisp_Object Vstack_trace_on_error;
127
128 /* List of conditions (non-nil atom means all) which enter the debugger
129 if an error is handled by the command loop's error handler. */
130 Lisp_Object Vdebug_on_error;
131
132 /* Nonzero means enter debugger if a quit signal
133 is handled by the command loop's error handler. */
134 int debug_on_quit;
135
136 /* The value of num_nonmacro_input_chars as of the last time we
137 started to enter the debugger. If we decide to enter the debugger
138 again when this is still equal to num_nonmacro_input_chars, then we
139 know that the debugger itself has an error, and we should just
140 signal the error instead of entering an infinite loop of debugger
141 invocations. */
142 int when_entered_debugger;
143
144 Lisp_Object Vdebugger;
145
146 void specbind (), record_unwind_protect ();
147
148 Lisp_Object funcall_lambda ();
149 extern Lisp_Object ml_apply (); /* Apply a mocklisp function to unevaluated argument list */
150
151 init_eval_once ()
152 {
153 specpdl_size = 50;
154 specpdl = (struct specbinding *) malloc (specpdl_size * sizeof (struct specbinding));
155 max_specpdl_size = 600;
156 max_lisp_eval_depth = 200;
157 }
158
159 init_eval ()
160 {
161 specpdl_ptr = specpdl;
162 catchlist = 0;
163 handlerlist = 0;
164 backtrace_list = 0;
165 Vquit_flag = Qnil;
166 debug_on_next_call = 0;
167 lisp_eval_depth = 0;
168 when_entered_debugger = 0;
169 }
170
171 Lisp_Object
172 call_debugger (arg)
173 Lisp_Object arg;
174 {
175 if (lisp_eval_depth + 20 > max_lisp_eval_depth)
176 max_lisp_eval_depth = lisp_eval_depth + 20;
177 if (specpdl_size + 40 > max_specpdl_size)
178 max_specpdl_size = specpdl_size + 40;
179 debug_on_next_call = 0;
180 when_entered_debugger = num_nonmacro_input_chars;
181 return apply1 (Vdebugger, arg);
182 }
183
184 do_debug_on_call (code)
185 Lisp_Object code;
186 {
187 debug_on_next_call = 0;
188 backtrace_list->debug_on_exit = 1;
189 call_debugger (Fcons (code, Qnil));
190 }
191 \f
192 /* NOTE!!! Every function that can call EVAL must protect its args
193 and temporaries from garbage collection while it needs them.
194 The definition of `For' shows what you have to do. */
195
196 DEFUN ("or", For, Sor, 0, UNEVALLED, 0,
197 "Eval args until one of them yields non-nil, then return that value.\n\
198 The remaining args are not evalled at all.\n\
199 If all args return nil, return nil.")
200 (args)
201 Lisp_Object args;
202 {
203 register Lisp_Object val;
204 Lisp_Object args_left;
205 struct gcpro gcpro1;
206
207 if (NILP(args))
208 return Qnil;
209
210 args_left = args;
211 GCPRO1 (args_left);
212
213 do
214 {
215 val = Feval (Fcar (args_left));
216 if (!NILP (val))
217 break;
218 args_left = Fcdr (args_left);
219 }
220 while (!NILP(args_left));
221
222 UNGCPRO;
223 return val;
224 }
225
226 DEFUN ("and", Fand, Sand, 0, UNEVALLED, 0,
227 "Eval args until one of them yields nil, then return nil.\n\
228 The remaining args are not evalled at all.\n\
229 If no arg yields nil, return the last arg's value.")
230 (args)
231 Lisp_Object args;
232 {
233 register Lisp_Object val;
234 Lisp_Object args_left;
235 struct gcpro gcpro1;
236
237 if (NILP(args))
238 return Qt;
239
240 args_left = args;
241 GCPRO1 (args_left);
242
243 do
244 {
245 val = Feval (Fcar (args_left));
246 if (NILP (val))
247 break;
248 args_left = Fcdr (args_left);
249 }
250 while (!NILP(args_left));
251
252 UNGCPRO;
253 return val;
254 }
255
256 DEFUN ("if", Fif, Sif, 2, UNEVALLED, 0,
257 "(if COND THEN ELSE...): if COND yields non-nil, do THEN, else do ELSE...\n\
258 Returns the value of THEN or the value of the last of the ELSE's.\n\
259 THEN must be one expression, but ELSE... can be zero or more expressions.\n\
260 If COND yields nil, and there are no ELSE's, the value is nil.")
261 (args)
262 Lisp_Object args;
263 {
264 register Lisp_Object cond;
265 struct gcpro gcpro1;
266
267 GCPRO1 (args);
268 cond = Feval (Fcar (args));
269 UNGCPRO;
270
271 if (!NILP (cond))
272 return Feval (Fcar (Fcdr (args)));
273 return Fprogn (Fcdr (Fcdr (args)));
274 }
275
276 DEFUN ("cond", Fcond, Scond, 0, UNEVALLED, 0,
277 "(cond CLAUSES...): try each clause until one succeeds.\n\
278 Each clause looks like (CONDITION BODY...). CONDITION is evaluated\n\
279 and, if the value is non-nil, this clause succeeds:\n\
280 then the expressions in BODY are evaluated and the last one's\n\
281 value is the value of the cond-form.\n\
282 If no clause succeeds, cond returns nil.\n\
283 If a clause has one element, as in (CONDITION),\n\
284 CONDITION's value if non-nil is returned from the cond-form.")
285 (args)
286 Lisp_Object args;
287 {
288 register Lisp_Object clause, val;
289 struct gcpro gcpro1;
290
291 val = Qnil;
292 GCPRO1 (args);
293 while (!NILP (args))
294 {
295 clause = Fcar (args);
296 val = Feval (Fcar (clause));
297 if (!NILP (val))
298 {
299 if (!EQ (XCONS (clause)->cdr, Qnil))
300 val = Fprogn (XCONS (clause)->cdr);
301 break;
302 }
303 args = XCONS (args)->cdr;
304 }
305 UNGCPRO;
306
307 return val;
308 }
309
310 DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
311 "(progn BODY...): eval BODY forms sequentially and return value of last one.")
312 (args)
313 Lisp_Object args;
314 {
315 register Lisp_Object val, tem;
316 Lisp_Object args_left;
317 struct gcpro gcpro1;
318
319 /* In Mocklisp code, symbols at the front of the progn arglist
320 are to be bound to zero. */
321 if (!EQ (Vmocklisp_arguments, Qt))
322 {
323 val = make_number (0);
324 while (!NILP (args) && (tem = Fcar (args), XTYPE (tem) == Lisp_Symbol))
325 {
326 QUIT;
327 specbind (tem, val), args = Fcdr (args);
328 }
329 }
330
331 if (NILP(args))
332 return Qnil;
333
334 args_left = args;
335 GCPRO1 (args_left);
336
337 do
338 {
339 val = Feval (Fcar (args_left));
340 args_left = Fcdr (args_left);
341 }
342 while (!NILP(args_left));
343
344 UNGCPRO;
345 return val;
346 }
347
348 DEFUN ("prog1", Fprog1, Sprog1, 1, UNEVALLED, 0,
349 "(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST.\n\
350 The value of FIRST is saved during the evaluation of the remaining args,\n\
351 whose values are discarded.")
352 (args)
353 Lisp_Object args;
354 {
355 Lisp_Object val;
356 register Lisp_Object args_left;
357 struct gcpro gcpro1, gcpro2;
358 register int argnum = 0;
359
360 if (NILP(args))
361 return Qnil;
362
363 args_left = args;
364 val = Qnil;
365 GCPRO2 (args, val);
366
367 do
368 {
369 if (!(argnum++))
370 val = Feval (Fcar (args_left));
371 else
372 Feval (Fcar (args_left));
373 args_left = Fcdr (args_left);
374 }
375 while (!NILP(args_left));
376
377 UNGCPRO;
378 return val;
379 }
380
381 DEFUN ("prog2", Fprog2, Sprog2, 2, UNEVALLED, 0,
382 "(prog1 X Y BODY...): eval X, Y and BODY sequentially; value from Y.\n\
383 The value of Y is saved during the evaluation of the remaining args,\n\
384 whose values are discarded.")
385 (args)
386 Lisp_Object args;
387 {
388 Lisp_Object val;
389 register Lisp_Object args_left;
390 struct gcpro gcpro1, gcpro2;
391 register int argnum = -1;
392
393 val = Qnil;
394
395 if (NILP(args))
396 return Qnil;
397
398 args_left = args;
399 val = Qnil;
400 GCPRO2 (args, val);
401
402 do
403 {
404 if (!(argnum++))
405 val = Feval (Fcar (args_left));
406 else
407 Feval (Fcar (args_left));
408 args_left = Fcdr (args_left);
409 }
410 while (!NILP(args_left));
411
412 UNGCPRO;
413 return val;
414 }
415
416 DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
417 "(setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.\n\
418 The SYMs are not evaluated. Thus (setq x y) sets x to the value of y.\n\
419 Each SYM is set before the next VAL is computed.")
420 (args)
421 Lisp_Object args;
422 {
423 register Lisp_Object args_left;
424 register Lisp_Object val, sym;
425 struct gcpro gcpro1;
426
427 if (NILP(args))
428 return Qnil;
429
430 args_left = args;
431 GCPRO1 (args);
432
433 do
434 {
435 val = Feval (Fcar (Fcdr (args_left)));
436 sym = Fcar (args_left);
437 Fset (sym, val);
438 args_left = Fcdr (Fcdr (args_left));
439 }
440 while (!NILP(args_left));
441
442 UNGCPRO;
443 return val;
444 }
445
446 DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0,
447 "Return the argument, without evaluating it. `(quote x)' yields `x'.")
448 (args)
449 Lisp_Object args;
450 {
451 return Fcar (args);
452 }
453
454 DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
455 "Like `quote', but preferred for objects which are functions.\n\
456 In byte compilation, `function' causes its argument to be compiled.\n\
457 `quote' cannot do that.")
458 (args)
459 Lisp_Object args;
460 {
461 return Fcar (args);
462 }
463
464 DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
465 "Return t if function in which this appears was called interactively.\n\
466 This means that the function was called with call-interactively (which\n\
467 includes being called as the binding of a key)\n\
468 and input is currently coming from the keyboard (not in keyboard macro).")
469 ()
470 {
471 register struct backtrace *btp;
472 register Lisp_Object fun;
473
474 if (!INTERACTIVE)
475 return Qnil;
476
477 btp = backtrace_list;
478
479 /* If this isn't a byte-compiled function, there may be a frame at
480 the top for Finteractive_p itself. If so, skip it. */
481 fun = Findirect_function (*btp->function);
482 if (XTYPE (fun) == Lisp_Subr
483 && (struct Lisp_Subr *) XPNTR (fun) == &Sinteractive_p)
484 btp = btp->next;
485
486 /* If we're running an Emacs 18-style byte-compiled function, there
487 may be a frame for Fbytecode. Now, given the strictest
488 definition, this function isn't really being called
489 interactively, but because that's the way Emacs 18 always builds
490 byte-compiled functions, we'll accept it for now. */
491 if (EQ (*btp->function, Qbytecode))
492 btp = btp->next;
493
494 /* If this isn't a byte-compiled function, then we may now be
495 looking at several frames for special forms. Skip past them. */
496 while (btp &&
497 btp->nargs == UNEVALLED)
498 btp = btp->next;
499
500 /* btp now points at the frame of the innermost function that isn't
501 a special form, ignoring frames for Finteractive_p and/or
502 Fbytecode at the top. If this frame is for a built-in function
503 (such as load or eval-region) return nil. */
504 fun = Findirect_function (*btp->function);
505 if (XTYPE (fun) == Lisp_Subr)
506 return Qnil;
507 /* btp points to the frame of a Lisp function that called interactive-p.
508 Return t if that function was called interactively. */
509 if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
510 return Qt;
511 return Qnil;
512 }
513
514 DEFUN ("defun", Fdefun, Sdefun, 2, UNEVALLED, 0,
515 "(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function.\n\
516 The definition is (lambda ARGLIST [DOCSTRING] BODY...).\n\
517 See also the function `interactive'.")
518 (args)
519 Lisp_Object args;
520 {
521 register Lisp_Object fn_name;
522 register Lisp_Object defn;
523
524 fn_name = Fcar (args);
525 defn = Fcons (Qlambda, Fcdr (args));
526 if (!NILP (Vpurify_flag))
527 defn = Fpurecopy (defn);
528 Ffset (fn_name, defn);
529 return fn_name;
530 }
531
532 DEFUN ("defmacro", Fdefmacro, Sdefmacro, 2, UNEVALLED, 0,
533 "(defmacro NAME ARGLIST [DOCSTRING] BODY...): define NAME as a macro.\n\
534 The definition is (macro lambda ARGLIST [DOCSTRING] BODY...).\n\
535 When the macro is called, as in (NAME ARGS...),\n\
536 the function (lambda ARGLIST BODY...) is applied to\n\
537 the list ARGS... as it appears in the expression,\n\
538 and the result should be a form to be evaluated instead of the original.")
539 (args)
540 Lisp_Object args;
541 {
542 register Lisp_Object fn_name;
543 register Lisp_Object defn;
544
545 fn_name = Fcar (args);
546 defn = Fcons (Qmacro, Fcons (Qlambda, Fcdr (args)));
547 if (!NILP (Vpurify_flag))
548 defn = Fpurecopy (defn);
549 Ffset (fn_name, defn);
550 return fn_name;
551 }
552
553 DEFUN ("defvar", Fdefvar, Sdefvar, 1, UNEVALLED, 0,
554 "(defvar SYMBOL INITVALUE DOCSTRING): define SYMBOL as a variable.\n\
555 You are not required to define a variable in order to use it,\n\
556 but the definition can supply documentation and an initial value\n\
557 in a way that tags can recognize.\n\n\
558 INITVALUE is evaluated, and used to set SYMBOL, only if SYMBOL's value is void.\n\
559 If SYMBOL is buffer-local, its default value is what is set;\n\
560 buffer-local values are not affected.\n\
561 INITVALUE and DOCSTRING are optional.\n\
562 If DOCSTRING starts with *, this variable is identified as a user option.\n\
563 This means that M-x set-variable and M-x edit-options recognize it.\n\
564 If INITVALUE is missing, SYMBOL's value is not set.")
565 (args)
566 Lisp_Object args;
567 {
568 register Lisp_Object sym, tem;
569
570 sym = Fcar (args);
571 tem = Fcdr (args);
572 if (!NILP (tem))
573 {
574 tem = Fdefault_boundp (sym);
575 if (NILP (tem))
576 Fset_default (sym, Feval (Fcar (Fcdr (args))));
577 }
578 tem = Fcar (Fcdr (Fcdr (args)));
579 if (!NILP (tem))
580 {
581 if (!NILP (Vpurify_flag))
582 tem = Fpurecopy (tem);
583 Fput (sym, Qvariable_documentation, tem);
584 }
585 return sym;
586 }
587
588 DEFUN ("defconst", Fdefconst, Sdefconst, 2, UNEVALLED, 0,
589 "(defconst SYMBOL INITVALUE DOCSTRING): define SYMBOL as a constant variable.\n\
590 The intent is that programs do not change this value, but users may.\n\
591 Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
592 If SYMBOL is buffer-local, its default value is what is set;\n\
593 buffer-local values are not affected.\n\
594 DOCSTRING is optional.\n\
595 If DOCSTRING starts with *, this variable is identified as a user option.\n\
596 This means that M-x set-variable and M-x edit-options recognize it.\n\n\
597 Note: do not use `defconst' for user options in libraries that are not\n\
598 normally loaded, since it is useful for users to be able to specify\n\
599 their own values for such variables before loading the library.\n\
600 Since `defconst' unconditionally assigns the variable,\n\
601 it would override the user's choice.")
602 (args)
603 Lisp_Object args;
604 {
605 register Lisp_Object sym, tem;
606
607 sym = Fcar (args);
608 Fset_default (sym, Feval (Fcar (Fcdr (args))));
609 tem = Fcar (Fcdr (Fcdr (args)));
610 if (!NILP (tem))
611 {
612 if (!NILP (Vpurify_flag))
613 tem = Fpurecopy (tem);
614 Fput (sym, Qvariable_documentation, tem);
615 }
616 return sym;
617 }
618
619 DEFUN ("user-variable-p", Fuser_variable_p, Suser_variable_p, 1, 1, 0,
620 "Returns t if VARIABLE is intended to be set and modified by users.\n\
621 \(The alternative is a variable used internally in a Lisp program.)\n\
622 Determined by whether the first character of the documentation\n\
623 for the variable is \"*\"")
624 (variable)
625 Lisp_Object variable;
626 {
627 Lisp_Object documentation;
628
629 documentation = Fget (variable, Qvariable_documentation);
630 if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0)
631 return Qt;
632 if ((XTYPE (documentation) == Lisp_String) &&
633 ((unsigned char) XSTRING (documentation)->data[0] == '*'))
634 return Qt;
635 return Qnil;
636 }
637 \f
638 DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
639 "(let* VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
640 The value of the last form in BODY is returned.\n\
641 Each element of VARLIST is a symbol (which is bound to nil)\n\
642 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
643 Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
644 (args)
645 Lisp_Object args;
646 {
647 Lisp_Object varlist, val, elt;
648 int count = specpdl_ptr - specpdl;
649 struct gcpro gcpro1, gcpro2, gcpro3;
650
651 GCPRO3 (args, elt, varlist);
652
653 varlist = Fcar (args);
654 while (!NILP (varlist))
655 {
656 QUIT;
657 elt = Fcar (varlist);
658 if (XTYPE (elt) == Lisp_Symbol)
659 specbind (elt, Qnil);
660 else if (! NILP (Fcdr (Fcdr (elt))))
661 Fsignal (Qerror,
662 Fcons (build_string ("`let' bindings can have only one value-form"),
663 elt));
664 else
665 {
666 val = Feval (Fcar (Fcdr (elt)));
667 specbind (Fcar (elt), val);
668 }
669 varlist = Fcdr (varlist);
670 }
671 UNGCPRO;
672 val = Fprogn (Fcdr (args));
673 return unbind_to (count, val);
674 }
675
676 DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
677 "(let VARLIST BODY...): bind variables according to VARLIST then eval BODY.\n\
678 The value of the last form in BODY is returned.\n\
679 Each element of VARLIST is a symbol (which is bound to nil)\n\
680 or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
681 All the VALUEFORMs are evalled before any symbols are bound.")
682 (args)
683 Lisp_Object args;
684 {
685 Lisp_Object *temps, tem;
686 register Lisp_Object elt, varlist;
687 int count = specpdl_ptr - specpdl;
688 register int argnum;
689 struct gcpro gcpro1, gcpro2;
690
691 varlist = Fcar (args);
692
693 /* Make space to hold the values to give the bound variables */
694 elt = Flength (varlist);
695 temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object));
696
697 /* Compute the values and store them in `temps' */
698
699 GCPRO2 (args, *temps);
700 gcpro2.nvars = 0;
701
702 for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
703 {
704 QUIT;
705 elt = Fcar (varlist);
706 if (XTYPE (elt) == Lisp_Symbol)
707 temps [argnum++] = Qnil;
708 else if (! NILP (Fcdr (Fcdr (elt))))
709 Fsignal (Qerror,
710 Fcons (build_string ("`let' bindings can have only one value-form"),
711 elt));
712 else
713 temps [argnum++] = Feval (Fcar (Fcdr (elt)));
714 gcpro2.nvars = argnum;
715 }
716 UNGCPRO;
717
718 varlist = Fcar (args);
719 for (argnum = 0; !NILP (varlist); varlist = Fcdr (varlist))
720 {
721 elt = Fcar (varlist);
722 tem = temps[argnum++];
723 if (XTYPE (elt) == Lisp_Symbol)
724 specbind (elt, tem);
725 else
726 specbind (Fcar (elt), tem);
727 }
728
729 elt = Fprogn (Fcdr (args));
730 return unbind_to (count, elt);
731 }
732
733 DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
734 "(while TEST BODY...): if TEST yields non-nil, eval BODY... and repeat.\n\
735 The order of execution is thus TEST, BODY, TEST, BODY and so on\n\
736 until TEST returns nil.")
737 (args)
738 Lisp_Object args;
739 {
740 Lisp_Object test, body, tem;
741 struct gcpro gcpro1, gcpro2;
742
743 GCPRO2 (test, body);
744
745 test = Fcar (args);
746 body = Fcdr (args);
747 while (tem = Feval (test), !NILP (tem))
748 {
749 QUIT;
750 Fprogn (body);
751 }
752
753 UNGCPRO;
754 return Qnil;
755 }
756
757 DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
758 "Return result of expanding macros at top level of FORM.\n\
759 If FORM is not a macro call, it is returned unchanged.\n\
760 Otherwise, the macro is expanded and the expansion is considered\n\
761 in place of FORM. When a non-macro-call results, it is returned.\n\n\
762 The second optional arg ENVIRONMENT species an environment of macro\n\
763 definitions to shadow the loaded ones for use in file byte-compilation.")
764 (form, env)
765 register Lisp_Object form;
766 Lisp_Object env;
767 {
768 /* With cleanups from Hallvard Furuseth. */
769 register Lisp_Object expander, sym, def, tem;
770
771 while (1)
772 {
773 /* Come back here each time we expand a macro call,
774 in case it expands into another macro call. */
775 if (XTYPE (form) != Lisp_Cons)
776 break;
777 /* Set SYM, give DEF and TEM right values in case SYM is not a symbol. */
778 def = sym = XCONS (form)->car;
779 tem = Qnil;
780 /* Trace symbols aliases to other symbols
781 until we get a symbol that is not an alias. */
782 while (XTYPE (def) == Lisp_Symbol)
783 {
784 QUIT;
785 sym = def;
786 tem = Fassq (sym, env);
787 if (NILP (tem))
788 {
789 def = XSYMBOL (sym)->function;
790 if (!EQ (def, Qunbound))
791 continue;
792 }
793 break;
794 }
795 /* Right now TEM is the result from SYM in ENV,
796 and if TEM is nil then DEF is SYM's function definition. */
797 if (NILP (tem))
798 {
799 /* SYM is not mentioned in ENV.
800 Look at its function definition. */
801 if (EQ (def, Qunbound)
802 || XTYPE (def) != Lisp_Cons)
803 /* Not defined or definition not suitable */
804 break;
805 if (EQ (XCONS (def)->car, Qautoload))
806 {
807 /* Autoloading function: will it be a macro when loaded? */
808 tem = Fcar (Fnthcdr (make_number (4), def));
809 if (NILP (tem))
810 break;
811 /* Yes, load it and try again. */
812 do_autoload (def, sym);
813 continue;
814 }
815 else if (!EQ (XCONS (def)->car, Qmacro))
816 break;
817 else expander = XCONS (def)->cdr;
818 }
819 else
820 {
821 expander = XCONS (tem)->cdr;
822 if (NILP (expander))
823 break;
824 }
825 form = apply1 (expander, XCONS (form)->cdr);
826 }
827 return form;
828 }
829 \f
830 DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
831 "(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.\n\
832 TAG is evalled to get the tag to use. Then the BODY is executed.\n\
833 Within BODY, (throw TAG) with same tag exits BODY and exits this `catch'.\n\
834 If no throw happens, `catch' returns the value of the last BODY form.\n\
835 If a throw happens, it specifies the value to return from `catch'.")
836 (args)
837 Lisp_Object args;
838 {
839 register Lisp_Object tag;
840 struct gcpro gcpro1;
841
842 GCPRO1 (args);
843 tag = Feval (Fcar (args));
844 UNGCPRO;
845 return internal_catch (tag, Fprogn, Fcdr (args));
846 }
847
848 /* Set up a catch, then call C function FUNC on argument ARG.
849 FUNC should return a Lisp_Object.
850 This is how catches are done from within C code. */
851
852 Lisp_Object
853 internal_catch (tag, func, arg)
854 Lisp_Object tag;
855 Lisp_Object (*func) ();
856 Lisp_Object arg;
857 {
858 /* This structure is made part of the chain `catchlist'. */
859 struct catchtag c;
860
861 /* Fill in the components of c, and put it on the list. */
862 c.next = catchlist;
863 c.tag = tag;
864 c.val = Qnil;
865 c.backlist = backtrace_list;
866 c.handlerlist = handlerlist;
867 c.lisp_eval_depth = lisp_eval_depth;
868 c.pdlcount = specpdl_ptr - specpdl;
869 c.poll_suppress_count = poll_suppress_count;
870 c.gcpro = gcprolist;
871 catchlist = &c;
872
873 /* Call FUNC. */
874 if (! _setjmp (c.jmp))
875 c.val = (*func) (arg);
876
877 /* Throw works by a longjmp that comes right here. */
878 catchlist = c.next;
879 return c.val;
880 }
881
882 /* Unwind the specbind, catch, and handler stacks back to CATCH, and
883 jump to that CATCH, returning VALUE as the value of that catch.
884
885 This is the guts Fthrow and Fsignal; they differ only in the way
886 they choose the catch tag to throw to. A catch tag for a
887 condition-case form has a TAG of Qnil.
888
889 Before each catch is discarded, unbind all special bindings and
890 execute all unwind-protect clauses made above that catch. Unwind
891 the handler stack as we go, so that the proper handlers are in
892 effect for each unwind-protect clause we run. At the end, restore
893 some static info saved in CATCH, and longjmp to the location
894 specified in the
895
896 This is used for correct unwinding in Fthrow and Fsignal. */
897
898 static void
899 unwind_to_catch (catch, value)
900 struct catchtag *catch;
901 Lisp_Object value;
902 {
903 register int last_time;
904
905 /* Save the value in the tag. */
906 catch->val = value;
907
908 /* Restore the polling-suppression count. */
909 if (catch->poll_suppress_count > poll_suppress_count)
910 abort ();
911 while (catch->poll_suppress_count < poll_suppress_count)
912 start_polling ();
913
914 do
915 {
916 last_time = catchlist == catch;
917
918 /* Unwind the specpdl stack, and then restore the proper set of
919 handlers. */
920 unbind_to (catchlist->pdlcount, Qnil);
921 handlerlist = catchlist->handlerlist;
922 catchlist = catchlist->next;
923 }
924 while (! last_time);
925
926 gcprolist = catch->gcpro;
927 backtrace_list = catch->backlist;
928 lisp_eval_depth = catch->lisp_eval_depth;
929
930 _longjmp (catch->jmp, 1);
931 }
932
933 DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
934 "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
935 Both TAG and VALUE are evalled.")
936 (tag, val)
937 register Lisp_Object tag, val;
938 {
939 register struct catchtag *c;
940
941 while (1)
942 {
943 if (!NILP (tag))
944 for (c = catchlist; c; c = c->next)
945 {
946 if (EQ (c->tag, tag))
947 unwind_to_catch (c, val);
948 }
949 tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil)));
950 }
951 }
952
953
954 DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
955 "Do BODYFORM, protecting with UNWINDFORMS.\n\
956 Usage looks like (unwind-protect BODYFORM UNWINDFORMS...).\n\
957 If BODYFORM completes normally, its value is returned\n\
958 after executing the UNWINDFORMS.\n\
959 If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
960 (args)
961 Lisp_Object args;
962 {
963 Lisp_Object val;
964 int count = specpdl_ptr - specpdl;
965
966 record_unwind_protect (0, Fcdr (args));
967 val = Feval (Fcar (args));
968 return unbind_to (count, val);
969 }
970 \f
971 /* Chain of condition handlers currently in effect.
972 The elements of this chain are contained in the stack frames
973 of Fcondition_case and internal_condition_case.
974 When an error is signaled (by calling Fsignal, below),
975 this chain is searched for an element that applies. */
976
977 struct handler *handlerlist;
978
979 DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
980 "Regain control when an error is signaled.\n\
981 Usage looks like (condition-case VAR BODYFORM HANDLERS...).\n\
982 executes BODYFORM and returns its value if no error happens.\n\
983 Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
984 where the BODY is made of Lisp expressions.\n\n\
985 A handler is applicable to an error\n\
986 if CONDITION-NAME is one of the error's condition names.\n\
987 If an error happens, the first applicable handler is run.\n\
988 \n\
989 When a handler handles an error,\n\
990 control returns to the condition-case and the handler BODY... is executed\n\
991 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
992 VAR may be nil; then you do not get access to the signal information.\n\
993 \n\
994 The value of the last BODY form is returned from the condition-case.\n\
995 See also the function `signal' for more info.")
996 (args)
997 Lisp_Object args;
998 {
999 Lisp_Object val;
1000 struct catchtag c;
1001 struct handler h;
1002 register Lisp_Object var, bodyform, handlers;
1003
1004 var = Fcar (args);
1005 bodyform = Fcar (Fcdr (args));
1006 handlers = Fcdr (Fcdr (args));
1007 CHECK_SYMBOL (var, 0);
1008
1009 for (val = handlers; ! NILP (val); val = Fcdr (val))
1010 {
1011 Lisp_Object tem;
1012 tem = Fcar (val);
1013 if ((!NILP (tem)) &&
1014 (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
1015 error ("Invalid condition handler", tem);
1016 }
1017
1018 c.tag = Qnil;
1019 c.val = Qnil;
1020 c.backlist = backtrace_list;
1021 c.handlerlist = handlerlist;
1022 c.lisp_eval_depth = lisp_eval_depth;
1023 c.pdlcount = specpdl_ptr - specpdl;
1024 c.poll_suppress_count = poll_suppress_count;
1025 c.gcpro = gcprolist;
1026 if (_setjmp (c.jmp))
1027 {
1028 if (!NILP (h.var))
1029 specbind (h.var, Fcdr (c.val));
1030 val = Fprogn (Fcdr (Fcar (c.val)));
1031
1032 /* Note that this just undoes the binding of h.var; whoever
1033 longjumped to us unwound the stack to c.pdlcount before
1034 throwing. */
1035 unbind_to (c.pdlcount, Qnil);
1036 return val;
1037 }
1038 c.next = catchlist;
1039 catchlist = &c;
1040
1041 h.var = var;
1042 h.handler = handlers;
1043 h.next = handlerlist;
1044 h.tag = &c;
1045 handlerlist = &h;
1046
1047 val = Feval (bodyform);
1048 catchlist = c.next;
1049 handlerlist = h.next;
1050 return val;
1051 }
1052
1053 Lisp_Object
1054 internal_condition_case (bfun, handlers, hfun)
1055 Lisp_Object (*bfun) ();
1056 Lisp_Object handlers;
1057 Lisp_Object (*hfun) ();
1058 {
1059 Lisp_Object val;
1060 struct catchtag c;
1061 struct handler h;
1062
1063 c.tag = Qnil;
1064 c.val = Qnil;
1065 c.backlist = backtrace_list;
1066 c.handlerlist = handlerlist;
1067 c.lisp_eval_depth = lisp_eval_depth;
1068 c.pdlcount = specpdl_ptr - specpdl;
1069 c.poll_suppress_count = poll_suppress_count;
1070 c.gcpro = gcprolist;
1071 if (_setjmp (c.jmp))
1072 {
1073 return (*hfun) (Fcdr (c.val));
1074 }
1075 c.next = catchlist;
1076 catchlist = &c;
1077 h.handler = handlers;
1078 h.var = Qnil;
1079 h.next = handlerlist;
1080 h.tag = &c;
1081 handlerlist = &h;
1082
1083 val = (*bfun) ();
1084 catchlist = c.next;
1085 handlerlist = h.next;
1086 return val;
1087 }
1088
1089 static Lisp_Object find_handler_clause ();
1090
1091 DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
1092 "Signal an error. Args are SIGNAL-NAME, and associated DATA.\n\
1093 This function does not return.\n\n\
1094 A signal name is a symbol with an `error-conditions' property\n\
1095 that is a list of condition names.\n\
1096 A handler for any of those names will get to handle this signal.\n\
1097 The symbol `error' should normally be one of them.\n\
1098 \n\
1099 DATA should be a list. Its elements are printed as part of the error message.\n\
1100 If the signal is handled, DATA is made available to the handler.\n\
1101 See also the function `condition-case'.")
1102 (sig, data)
1103 Lisp_Object sig, data;
1104 {
1105 register struct handler *allhandlers = handlerlist;
1106 Lisp_Object conditions;
1107 extern int gc_in_progress;
1108 extern int waiting_for_input;
1109 Lisp_Object debugger_value;
1110
1111 quit_error_check ();
1112 immediate_quit = 0;
1113 if (gc_in_progress || waiting_for_input)
1114 abort ();
1115
1116 #ifdef HAVE_X_WINDOWS
1117 TOTALLY_UNBLOCK_INPUT;
1118 #endif
1119
1120 conditions = Fget (sig, Qerror_conditions);
1121
1122 for (; handlerlist; handlerlist = handlerlist->next)
1123 {
1124 register Lisp_Object clause;
1125 clause = find_handler_clause (handlerlist->handler, conditions,
1126 sig, data, &debugger_value);
1127
1128 #if 0 /* Most callers are not prepared to handle gc if this returns.
1129 So, since this feature is not very useful, take it out. */
1130 /* If have called debugger and user wants to continue,
1131 just return nil. */
1132 if (EQ (clause, Qlambda))
1133 return debugger_value;
1134 #else
1135 if (EQ (clause, Qlambda))
1136 {
1137 /* We can't return values to code which signalled an error, but we
1138 can continue code which has signalled a quit. */
1139 if (EQ (sig, Qquit))
1140 return Qnil;
1141 else
1142 error ("Returning a value from an error is no longer supported");
1143 }
1144 #endif
1145
1146 if (!NILP (clause))
1147 {
1148 struct handler *h = handlerlist;
1149 handlerlist = allhandlers;
1150 unwind_to_catch (h->tag, Fcons (clause, Fcons (sig, data)));
1151 }
1152 }
1153
1154 handlerlist = allhandlers;
1155 /* If no handler is present now, try to run the debugger,
1156 and if that fails, throw to top level. */
1157 find_handler_clause (Qerror, conditions, sig, data, &debugger_value);
1158 Fthrow (Qtop_level, Qt);
1159 }
1160
1161 /* Return nonzero iff LIST is a non-nil atom or
1162 a list containing one of CONDITIONS. */
1163
1164 static int
1165 wants_debugger (list, conditions)
1166 Lisp_Object list, conditions;
1167 {
1168 if (NILP (list))
1169 return 0;
1170 if (! CONSP (list))
1171 return 1;
1172
1173 while (CONSP (conditions))
1174 {
1175 Lisp_Object this, tail;
1176 this = XCONS (conditions)->car;
1177 for (tail = list; CONSP (tail); tail = XCONS (tail)->cdr)
1178 if (EQ (XCONS (tail)->car, this))
1179 return 1;
1180 conditions = XCONS (conditions)->cdr;
1181 }
1182 return 0;
1183 }
1184
1185 /* Value of Qlambda means we have called debugger and user has continued.
1186 Store value returned from debugger into *DEBUGGER_VALUE_PTR. */
1187
1188 static Lisp_Object
1189 find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr)
1190 Lisp_Object handlers, conditions, sig, data;
1191 Lisp_Object *debugger_value_ptr;
1192 {
1193 register Lisp_Object h;
1194 register Lisp_Object tem;
1195 register Lisp_Object tem1;
1196
1197 if (EQ (handlers, Qt)) /* t is used by handlers for all conditions, set up by C code. */
1198 return Qt;
1199 if (EQ (handlers, Qerror)) /* error is used similarly, but means display a backtrace too */
1200 {
1201 if (wants_debugger (Vstack_trace_on_error, conditions))
1202 internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil);
1203 if ((EQ (sig, Qquit)
1204 ? debug_on_quit
1205 : wants_debugger (Vdebug_on_error, conditions))
1206 && when_entered_debugger < num_nonmacro_input_chars)
1207 {
1208 int count = specpdl_ptr - specpdl;
1209 specbind (Qdebug_on_error, Qnil);
1210 *debugger_value_ptr =
1211 call_debugger (Fcons (Qerror,
1212 Fcons (Fcons (sig, data),
1213 Qnil)));
1214 return unbind_to (count, Qlambda);
1215 }
1216 return Qt;
1217 }
1218 for (h = handlers; CONSP (h); h = Fcdr (h))
1219 {
1220 tem1 = Fcar (h);
1221 if (!CONSP (tem1))
1222 continue;
1223 tem = Fmemq (Fcar (tem1), conditions);
1224 if (!NILP (tem))
1225 return tem1;
1226 }
1227 return Qnil;
1228 }
1229
1230 /* dump an error message; called like printf */
1231
1232 /* VARARGS 1 */
1233 void
1234 error (m, a1, a2, a3)
1235 char *m;
1236 {
1237 char buf[200];
1238 sprintf (buf, m, a1, a2, a3);
1239
1240 while (1)
1241 Fsignal (Qerror, Fcons (build_string (buf), Qnil));
1242 }
1243 \f
1244 DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0,
1245 "T if FUNCTION makes provisions for interactive calling.\n\
1246 This means it contains a description for how to read arguments to give it.\n\
1247 The value is nil for an invalid function or a symbol with no function\n\
1248 definition.\n\
1249 \n\
1250 Interactively callable functions include strings and vectors (treated\n\
1251 as keyboard macros), lambda-expressions that contain a top-level call\n\
1252 to `interactive', autoload definitions made by `autoload' with non-nil\n\
1253 fourth argument, and some of the built-in functions of Lisp.\n\
1254 \n\
1255 Also, a symbol satisfies `commandp' if its function definition does so.")
1256 (function)
1257 Lisp_Object function;
1258 {
1259 register Lisp_Object fun;
1260 register Lisp_Object funcar;
1261 register Lisp_Object tem;
1262 register int i = 0;
1263
1264 fun = function;
1265
1266 fun = indirect_function (fun);
1267 if (EQ (fun, Qunbound))
1268 return Qnil;
1269
1270 /* Emacs primitives are interactive if their DEFUN specifies an
1271 interactive spec. */
1272 if (XTYPE (fun) == Lisp_Subr)
1273 {
1274 if (XSUBR (fun)->prompt)
1275 return Qt;
1276 else
1277 return Qnil;
1278 }
1279
1280 /* Bytecode objects are interactive if they are long enough to
1281 have an element whose index is COMPILED_INTERACTIVE, which is
1282 where the interactive spec is stored. */
1283 else if (XTYPE (fun) == Lisp_Compiled)
1284 return (XVECTOR (fun)->size > COMPILED_INTERACTIVE
1285 ? Qt : Qnil);
1286
1287 /* Strings and vectors are keyboard macros. */
1288 if (XTYPE (fun) == Lisp_String
1289 || XTYPE (fun) == Lisp_Vector)
1290 return Qt;
1291
1292 /* Lists may represent commands. */
1293 if (!CONSP (fun))
1294 return Qnil;
1295 funcar = Fcar (fun);
1296 if (XTYPE (funcar) != Lisp_Symbol)
1297 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1298 if (EQ (funcar, Qlambda))
1299 return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
1300 if (EQ (funcar, Qmocklisp))
1301 return Qt; /* All mocklisp functions can be called interactively */
1302 if (EQ (funcar, Qautoload))
1303 return Fcar (Fcdr (Fcdr (Fcdr (fun))));
1304 else
1305 return Qnil;
1306 }
1307
1308 /* ARGSUSED */
1309 DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
1310 "Define FUNCTION to autoload from FILE.\n\
1311 FUNCTION is a symbol; FILE is a file name string to pass to `load'.\n\
1312 Third arg DOCSTRING is documentation for the function.\n\
1313 Fourth arg INTERACTIVE if non-nil says function can be called interactively.\n\
1314 Fifth arg MACRO if non-nil says the function is really a macro.\n\
1315 Third through fifth args give info about the real definition.\n\
1316 They default to nil.\n\
1317 If FUNCTION is already defined other than as an autoload,\n\
1318 this does nothing and returns nil.")
1319 (function, file, docstring, interactive, macro)
1320 Lisp_Object function, file, docstring, interactive, macro;
1321 {
1322 #ifdef NO_ARG_ARRAY
1323 Lisp_Object args[4];
1324 #endif
1325
1326 CHECK_SYMBOL (function, 0);
1327 CHECK_STRING (file, 1);
1328
1329 /* If function is defined and not as an autoload, don't override */
1330 if (!EQ (XSYMBOL (function)->function, Qunbound)
1331 && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons
1332 && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload)))
1333 return Qnil;
1334
1335 #ifdef NO_ARG_ARRAY
1336 args[0] = file;
1337 args[1] = docstring;
1338 args[2] = interactive;
1339 args[3] = macro;
1340
1341 return Ffset (function, Fcons (Qautoload, Flist (4, &args[0])));
1342 #else /* NO_ARG_ARRAY */
1343 return Ffset (function, Fcons (Qautoload, Flist (4, &file)));
1344 #endif /* not NO_ARG_ARRAY */
1345 }
1346
1347 Lisp_Object
1348 un_autoload (oldqueue)
1349 Lisp_Object oldqueue;
1350 {
1351 register Lisp_Object queue, first, second;
1352
1353 /* Queue to unwind is current value of Vautoload_queue.
1354 oldqueue is the shadowed value to leave in Vautoload_queue. */
1355 queue = Vautoload_queue;
1356 Vautoload_queue = oldqueue;
1357 while (CONSP (queue))
1358 {
1359 first = Fcar (queue);
1360 second = Fcdr (first);
1361 first = Fcar (first);
1362 if (EQ (second, Qnil))
1363 Vfeatures = first;
1364 else
1365 Ffset (first, second);
1366 queue = Fcdr (queue);
1367 }
1368 return Qnil;
1369 }
1370
1371 do_autoload (fundef, funname)
1372 Lisp_Object fundef, funname;
1373 {
1374 int count = specpdl_ptr - specpdl;
1375 Lisp_Object fun, val;
1376
1377 fun = funname;
1378 CHECK_SYMBOL (funname, 0);
1379
1380 /* Value saved here is to be restored into Vautoload_queue */
1381 record_unwind_protect (un_autoload, Vautoload_queue);
1382 Vautoload_queue = Qt;
1383 Fload (Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
1384 /* Once loading finishes, don't undo it. */
1385 Vautoload_queue = Qt;
1386 unbind_to (count, Qnil);
1387
1388 fun = Findirect_function (fun);
1389
1390 if (XTYPE (fun) == Lisp_Cons
1391 && EQ (XCONS (fun)->car, Qautoload))
1392 error ("Autoloading failed to define function %s",
1393 XSYMBOL (funname)->name->data);
1394 }
1395 \f
1396 DEFUN ("eval", Feval, Seval, 1, 1, 0,
1397 "Evaluate FORM and return its value.")
1398 (form)
1399 Lisp_Object form;
1400 {
1401 Lisp_Object fun, val, original_fun, original_args;
1402 Lisp_Object funcar;
1403 struct backtrace backtrace;
1404 struct gcpro gcpro1, gcpro2, gcpro3;
1405
1406 if (XTYPE (form) == Lisp_Symbol)
1407 {
1408 if (EQ (Vmocklisp_arguments, Qt))
1409 return Fsymbol_value (form);
1410 val = Fsymbol_value (form);
1411 if (NILP (val))
1412 XFASTINT (val) = 0;
1413 else if (EQ (val, Qt))
1414 XFASTINT (val) = 1;
1415 return val;
1416 }
1417 if (!CONSP (form))
1418 return form;
1419
1420 QUIT;
1421 if (consing_since_gc > gc_cons_threshold)
1422 {
1423 GCPRO1 (form);
1424 Fgarbage_collect ();
1425 UNGCPRO;
1426 }
1427
1428 if (++lisp_eval_depth > max_lisp_eval_depth)
1429 {
1430 if (max_lisp_eval_depth < 100)
1431 max_lisp_eval_depth = 100;
1432 if (lisp_eval_depth > max_lisp_eval_depth)
1433 error ("Lisp nesting exceeds max-lisp-eval-depth");
1434 }
1435
1436 original_fun = Fcar (form);
1437 original_args = Fcdr (form);
1438
1439 backtrace.next = backtrace_list;
1440 backtrace_list = &backtrace;
1441 backtrace.function = &original_fun; /* This also protects them from gc */
1442 backtrace.args = &original_args;
1443 backtrace.nargs = UNEVALLED;
1444 backtrace.evalargs = 1;
1445 backtrace.debug_on_exit = 0;
1446
1447 if (debug_on_next_call)
1448 do_debug_on_call (Qt);
1449
1450 /* At this point, only original_fun and original_args
1451 have values that will be used below */
1452 retry:
1453 fun = Findirect_function (original_fun);
1454
1455 if (XTYPE (fun) == Lisp_Subr)
1456 {
1457 Lisp_Object numargs;
1458 Lisp_Object argvals[7];
1459 Lisp_Object args_left;
1460 register int i, maxargs;
1461
1462 args_left = original_args;
1463 numargs = Flength (args_left);
1464
1465 if (XINT (numargs) < XSUBR (fun)->min_args ||
1466 (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
1467 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
1468
1469 if (XSUBR (fun)->max_args == UNEVALLED)
1470 {
1471 backtrace.evalargs = 0;
1472 val = (*XSUBR (fun)->function) (args_left);
1473 goto done;
1474 }
1475
1476 if (XSUBR (fun)->max_args == MANY)
1477 {
1478 /* Pass a vector of evaluated arguments */
1479 Lisp_Object *vals;
1480 register int argnum = 0;
1481
1482 vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1483
1484 GCPRO3 (args_left, fun, fun);
1485 gcpro3.var = vals;
1486 gcpro3.nvars = 0;
1487
1488 while (!NILP (args_left))
1489 {
1490 vals[argnum++] = Feval (Fcar (args_left));
1491 args_left = Fcdr (args_left);
1492 gcpro3.nvars = argnum;
1493 }
1494
1495 backtrace.args = vals;
1496 backtrace.nargs = XINT (numargs);
1497
1498 val = (*XSUBR (fun)->function) (XINT (numargs), vals);
1499 UNGCPRO;
1500 goto done;
1501 }
1502
1503 GCPRO3 (args_left, fun, fun);
1504 gcpro3.var = argvals;
1505 gcpro3.nvars = 0;
1506
1507 maxargs = XSUBR (fun)->max_args;
1508 for (i = 0; i < maxargs; args_left = Fcdr (args_left))
1509 {
1510 argvals[i] = Feval (Fcar (args_left));
1511 gcpro3.nvars = ++i;
1512 }
1513
1514 UNGCPRO;
1515
1516 backtrace.args = argvals;
1517 backtrace.nargs = XINT (numargs);
1518
1519 switch (i)
1520 {
1521 case 0:
1522 val = (*XSUBR (fun)->function) ();
1523 goto done;
1524 case 1:
1525 val = (*XSUBR (fun)->function) (argvals[0]);
1526 goto done;
1527 case 2:
1528 val = (*XSUBR (fun)->function) (argvals[0], argvals[1]);
1529 goto done;
1530 case 3:
1531 val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1532 argvals[2]);
1533 goto done;
1534 case 4:
1535 val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
1536 argvals[2], argvals[3]);
1537 goto done;
1538 case 5:
1539 val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1540 argvals[3], argvals[4]);
1541 goto done;
1542 case 6:
1543 val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1544 argvals[3], argvals[4], argvals[5]);
1545 goto done;
1546 case 7:
1547 val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
1548 argvals[3], argvals[4], argvals[5],
1549 argvals[6]);
1550 goto done;
1551
1552 default:
1553 /* Someone has created a subr that takes more arguments than
1554 is supported by this code. We need to either rewrite the
1555 subr to use a different argument protocol, or add more
1556 cases to this switch. */
1557 abort ();
1558 }
1559 }
1560 if (XTYPE (fun) == Lisp_Compiled)
1561 val = apply_lambda (fun, original_args, 1);
1562 else
1563 {
1564 if (!CONSP (fun))
1565 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1566 funcar = Fcar (fun);
1567 if (XTYPE (funcar) != Lisp_Symbol)
1568 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1569 if (EQ (funcar, Qautoload))
1570 {
1571 do_autoload (fun, original_fun);
1572 goto retry;
1573 }
1574 if (EQ (funcar, Qmacro))
1575 val = Feval (apply1 (Fcdr (fun), original_args));
1576 else if (EQ (funcar, Qlambda))
1577 val = apply_lambda (fun, original_args, 1);
1578 else if (EQ (funcar, Qmocklisp))
1579 val = ml_apply (fun, original_args);
1580 else
1581 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1582 }
1583 done:
1584 if (!EQ (Vmocklisp_arguments, Qt))
1585 {
1586 if (NILP (val))
1587 XFASTINT (val) = 0;
1588 else if (EQ (val, Qt))
1589 XFASTINT (val) = 1;
1590 }
1591 lisp_eval_depth--;
1592 if (backtrace.debug_on_exit)
1593 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1594 backtrace_list = backtrace.next;
1595 return val;
1596 }
1597 \f
1598 DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
1599 "Call FUNCTION with our remaining args, using our last arg as list of args.\n\
1600 Thus, (apply '+ 1 2 '(3 4)) returns 10.")
1601 (nargs, args)
1602 int nargs;
1603 Lisp_Object *args;
1604 {
1605 register int i, numargs;
1606 register Lisp_Object spread_arg;
1607 register Lisp_Object *funcall_args;
1608 Lisp_Object fun;
1609 struct gcpro gcpro1;
1610
1611 fun = args [0];
1612 funcall_args = 0;
1613 spread_arg = args [nargs - 1];
1614 CHECK_LIST (spread_arg, nargs);
1615
1616 numargs = XINT (Flength (spread_arg));
1617
1618 if (numargs == 0)
1619 return Ffuncall (nargs - 1, args);
1620 else if (numargs == 1)
1621 {
1622 args [nargs - 1] = XCONS (spread_arg)->car;
1623 return Ffuncall (nargs, args);
1624 }
1625
1626 numargs += nargs - 2;
1627
1628 fun = indirect_function (fun);
1629 if (EQ (fun, Qunbound))
1630 {
1631 /* Let funcall get the error */
1632 fun = args[0];
1633 goto funcall;
1634 }
1635
1636 if (XTYPE (fun) == Lisp_Subr)
1637 {
1638 if (numargs < XSUBR (fun)->min_args
1639 || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1640 goto funcall; /* Let funcall get the error */
1641 else if (XSUBR (fun)->max_args > numargs)
1642 {
1643 /* Avoid making funcall cons up a yet another new vector of arguments
1644 by explicitly supplying nil's for optional values */
1645 funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args)
1646 * sizeof (Lisp_Object));
1647 for (i = numargs; i < XSUBR (fun)->max_args;)
1648 funcall_args[++i] = Qnil;
1649 GCPRO1 (*funcall_args);
1650 gcpro1.nvars = 1 + XSUBR (fun)->max_args;
1651 }
1652 }
1653 funcall:
1654 /* We add 1 to numargs because funcall_args includes the
1655 function itself as well as its arguments. */
1656 if (!funcall_args)
1657 {
1658 funcall_args = (Lisp_Object *) alloca ((1 + numargs)
1659 * sizeof (Lisp_Object));
1660 GCPRO1 (*funcall_args);
1661 gcpro1.nvars = 1 + numargs;
1662 }
1663
1664 bcopy (args, funcall_args, nargs * sizeof (Lisp_Object));
1665 /* Spread the last arg we got. Its first element goes in
1666 the slot that it used to occupy, hence this value of I. */
1667 i = nargs - 1;
1668 while (!NILP (spread_arg))
1669 {
1670 funcall_args [i++] = XCONS (spread_arg)->car;
1671 spread_arg = XCONS (spread_arg)->cdr;
1672 }
1673
1674 RETURN_UNGCPRO (Ffuncall (gcpro1.nvars, funcall_args));
1675 }
1676 \f
1677 /* Apply fn to arg */
1678 Lisp_Object
1679 apply1 (fn, arg)
1680 Lisp_Object fn, arg;
1681 {
1682 struct gcpro gcpro1;
1683
1684 GCPRO1 (fn);
1685 if (NILP (arg))
1686 RETURN_UNGCPRO (Ffuncall (1, &fn));
1687 gcpro1.nvars = 2;
1688 #ifdef NO_ARG_ARRAY
1689 {
1690 Lisp_Object args[2];
1691 args[0] = fn;
1692 args[1] = arg;
1693 gcpro1.var = args;
1694 RETURN_UNGCPRO (Fapply (2, args));
1695 }
1696 #else /* not NO_ARG_ARRAY */
1697 RETURN_UNGCPRO (Fapply (2, &fn));
1698 #endif /* not NO_ARG_ARRAY */
1699 }
1700
1701 /* Call function fn on no arguments */
1702 Lisp_Object
1703 call0 (fn)
1704 Lisp_Object fn;
1705 {
1706 struct gcpro gcpro1;
1707
1708 GCPRO1 (fn);
1709 RETURN_UNGCPRO (Ffuncall (1, &fn));
1710 }
1711
1712 /* Call function fn with argument arg */
1713 /* ARGSUSED */
1714 Lisp_Object
1715 call1 (fn, arg)
1716 Lisp_Object fn, arg;
1717 {
1718 struct gcpro gcpro1;
1719 #ifdef NO_ARG_ARRAY
1720 Lisp_Object args[2];
1721
1722 args[0] = fn;
1723 args[1] = arg;
1724 GCPRO1 (args[0]);
1725 gcpro1.nvars = 2;
1726 RETURN_UNGCPRO (Ffuncall (2, args));
1727 #else /* not NO_ARG_ARRAY */
1728 GCPRO1 (fn);
1729 gcpro1.nvars = 2;
1730 RETURN_UNGCPRO (Ffuncall (2, &fn));
1731 #endif /* not NO_ARG_ARRAY */
1732 }
1733
1734 /* Call function fn with arguments arg, arg1 */
1735 /* ARGSUSED */
1736 Lisp_Object
1737 call2 (fn, arg, arg1)
1738 Lisp_Object fn, arg, arg1;
1739 {
1740 struct gcpro gcpro1;
1741 #ifdef NO_ARG_ARRAY
1742 Lisp_Object args[3];
1743 args[0] = fn;
1744 args[1] = arg;
1745 args[2] = arg1;
1746 GCPRO1 (args[0]);
1747 gcpro1.nvars = 3;
1748 RETURN_UNGCPRO (Ffuncall (3, args));
1749 #else /* not NO_ARG_ARRAY */
1750 GCPRO1 (fn);
1751 gcpro1.nvars = 3;
1752 RETURN_UNGCPRO (Ffuncall (3, &fn));
1753 #endif /* not NO_ARG_ARRAY */
1754 }
1755
1756 /* Call function fn with arguments arg, arg1, arg2 */
1757 /* ARGSUSED */
1758 Lisp_Object
1759 call3 (fn, arg, arg1, arg2)
1760 Lisp_Object fn, arg, arg1, arg2;
1761 {
1762 struct gcpro gcpro1;
1763 #ifdef NO_ARG_ARRAY
1764 Lisp_Object args[4];
1765 args[0] = fn;
1766 args[1] = arg;
1767 args[2] = arg1;
1768 args[3] = arg2;
1769 GCPRO1 (args[0]);
1770 gcpro1.nvars = 4;
1771 RETURN_UNGCPRO (Ffuncall (4, args));
1772 #else /* not NO_ARG_ARRAY */
1773 GCPRO1 (fn);
1774 gcpro1.nvars = 4;
1775 RETURN_UNGCPRO (Ffuncall (4, &fn));
1776 #endif /* not NO_ARG_ARRAY */
1777 }
1778
1779 DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
1780 "Call first argument as a function, passing remaining arguments to it.\n\
1781 Thus, (funcall 'cons 'x 'y) returns (x . y).")
1782 (nargs, args)
1783 int nargs;
1784 Lisp_Object *args;
1785 {
1786 Lisp_Object fun;
1787 Lisp_Object funcar;
1788 int numargs = nargs - 1;
1789 Lisp_Object lisp_numargs;
1790 Lisp_Object val;
1791 struct backtrace backtrace;
1792 register Lisp_Object *internal_args;
1793 register int i;
1794
1795 QUIT;
1796 if (consing_since_gc > gc_cons_threshold)
1797 Fgarbage_collect ();
1798
1799 if (++lisp_eval_depth > max_lisp_eval_depth)
1800 {
1801 if (max_lisp_eval_depth < 100)
1802 max_lisp_eval_depth = 100;
1803 if (lisp_eval_depth > max_lisp_eval_depth)
1804 error ("Lisp nesting exceeds max-lisp-eval-depth");
1805 }
1806
1807 backtrace.next = backtrace_list;
1808 backtrace_list = &backtrace;
1809 backtrace.function = &args[0];
1810 backtrace.args = &args[1];
1811 backtrace.nargs = nargs - 1;
1812 backtrace.evalargs = 0;
1813 backtrace.debug_on_exit = 0;
1814
1815 if (debug_on_next_call)
1816 do_debug_on_call (Qlambda);
1817
1818 retry:
1819
1820 fun = args[0];
1821
1822 fun = Findirect_function (fun);
1823
1824 if (XTYPE (fun) == Lisp_Subr)
1825 {
1826 if (numargs < XSUBR (fun)->min_args
1827 || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
1828 {
1829 XFASTINT (lisp_numargs) = numargs;
1830 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (lisp_numargs, Qnil)));
1831 }
1832
1833 if (XSUBR (fun)->max_args == UNEVALLED)
1834 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1835
1836 if (XSUBR (fun)->max_args == MANY)
1837 {
1838 val = (*XSUBR (fun)->function) (numargs, args + 1);
1839 goto done;
1840 }
1841
1842 if (XSUBR (fun)->max_args > numargs)
1843 {
1844 internal_args = (Lisp_Object *) alloca (XSUBR (fun)->max_args * sizeof (Lisp_Object));
1845 bcopy (args + 1, internal_args, numargs * sizeof (Lisp_Object));
1846 for (i = numargs; i < XSUBR (fun)->max_args; i++)
1847 internal_args[i] = Qnil;
1848 }
1849 else
1850 internal_args = args + 1;
1851 switch (XSUBR (fun)->max_args)
1852 {
1853 case 0:
1854 val = (*XSUBR (fun)->function) ();
1855 goto done;
1856 case 1:
1857 val = (*XSUBR (fun)->function) (internal_args[0]);
1858 goto done;
1859 case 2:
1860 val = (*XSUBR (fun)->function) (internal_args[0],
1861 internal_args[1]);
1862 goto done;
1863 case 3:
1864 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1865 internal_args[2]);
1866 goto done;
1867 case 4:
1868 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1869 internal_args[2],
1870 internal_args[3]);
1871 goto done;
1872 case 5:
1873 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1874 internal_args[2], internal_args[3],
1875 internal_args[4]);
1876 goto done;
1877 case 6:
1878 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1879 internal_args[2], internal_args[3],
1880 internal_args[4], internal_args[5]);
1881 goto done;
1882 case 7:
1883 val = (*XSUBR (fun)->function) (internal_args[0], internal_args[1],
1884 internal_args[2], internal_args[3],
1885 internal_args[4], internal_args[5],
1886 internal_args[6]);
1887 goto done;
1888
1889 default:
1890
1891 /* If a subr takes more than 6 arguments without using MANY
1892 or UNEVALLED, we need to extend this function to support it.
1893 Until this is done, there is no way to call the function. */
1894 abort ();
1895 }
1896 }
1897 if (XTYPE (fun) == Lisp_Compiled)
1898 val = funcall_lambda (fun, numargs, args + 1);
1899 else
1900 {
1901 if (!CONSP (fun))
1902 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1903 funcar = Fcar (fun);
1904 if (XTYPE (funcar) != Lisp_Symbol)
1905 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1906 if (EQ (funcar, Qlambda))
1907 val = funcall_lambda (fun, numargs, args + 1);
1908 else if (EQ (funcar, Qmocklisp))
1909 val = ml_apply (fun, Flist (numargs, args + 1));
1910 else if (EQ (funcar, Qautoload))
1911 {
1912 do_autoload (fun, args[0]);
1913 goto retry;
1914 }
1915 else
1916 return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
1917 }
1918 done:
1919 lisp_eval_depth--;
1920 if (backtrace.debug_on_exit)
1921 val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
1922 backtrace_list = backtrace.next;
1923 return val;
1924 }
1925 \f
1926 Lisp_Object
1927 apply_lambda (fun, args, eval_flag)
1928 Lisp_Object fun, args;
1929 int eval_flag;
1930 {
1931 Lisp_Object args_left;
1932 Lisp_Object numargs;
1933 register Lisp_Object *arg_vector;
1934 struct gcpro gcpro1, gcpro2, gcpro3;
1935 register int i;
1936 register Lisp_Object tem;
1937
1938 numargs = Flength (args);
1939 arg_vector = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));
1940 args_left = args;
1941
1942 GCPRO3 (*arg_vector, args_left, fun);
1943 gcpro1.nvars = 0;
1944
1945 for (i = 0; i < XINT (numargs);)
1946 {
1947 tem = Fcar (args_left), args_left = Fcdr (args_left);
1948 if (eval_flag) tem = Feval (tem);
1949 arg_vector[i++] = tem;
1950 gcpro1.nvars = i;
1951 }
1952
1953 UNGCPRO;
1954
1955 if (eval_flag)
1956 {
1957 backtrace_list->args = arg_vector;
1958 backtrace_list->nargs = i;
1959 }
1960 backtrace_list->evalargs = 0;
1961 tem = funcall_lambda (fun, XINT (numargs), arg_vector);
1962
1963 /* Do the debug-on-exit now, while arg_vector still exists. */
1964 if (backtrace_list->debug_on_exit)
1965 tem = call_debugger (Fcons (Qexit, Fcons (tem, Qnil)));
1966 /* Don't do it again when we return to eval. */
1967 backtrace_list->debug_on_exit = 0;
1968 return tem;
1969 }
1970
1971 /* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
1972 and return the result of evaluation.
1973 FUN must be either a lambda-expression or a compiled-code object. */
1974
1975 Lisp_Object
1976 funcall_lambda (fun, nargs, arg_vector)
1977 Lisp_Object fun;
1978 int nargs;
1979 register Lisp_Object *arg_vector;
1980 {
1981 Lisp_Object val, tem;
1982 register Lisp_Object syms_left;
1983 Lisp_Object numargs;
1984 register Lisp_Object next;
1985 int count = specpdl_ptr - specpdl;
1986 register int i;
1987 int optional = 0, rest = 0;
1988
1989 specbind (Qmocklisp_arguments, Qt); /* t means NOT mocklisp! */
1990
1991 XFASTINT (numargs) = nargs;
1992
1993 if (XTYPE (fun) == Lisp_Cons)
1994 syms_left = Fcar (Fcdr (fun));
1995 else if (XTYPE (fun) == Lisp_Compiled)
1996 syms_left = XVECTOR (fun)->contents[COMPILED_ARGLIST];
1997 else abort ();
1998
1999 i = 0;
2000 for (; !NILP (syms_left); syms_left = Fcdr (syms_left))
2001 {
2002 QUIT;
2003 next = Fcar (syms_left);
2004 while (XTYPE (next) != Lisp_Symbol)
2005 next = Fsignal (Qinvalid_function, Fcons (fun, Qnil));
2006 if (EQ (next, Qand_rest))
2007 rest = 1;
2008 else if (EQ (next, Qand_optional))
2009 optional = 1;
2010 else if (rest)
2011 {
2012 specbind (next, Flist (nargs - i, &arg_vector[i]));
2013 i = nargs;
2014 }
2015 else if (i < nargs)
2016 {
2017 tem = arg_vector[i++];
2018 specbind (next, tem);
2019 }
2020 else if (!optional)
2021 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
2022 else
2023 specbind (next, Qnil);
2024 }
2025
2026 if (i < nargs)
2027 return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));
2028
2029 if (XTYPE (fun) == Lisp_Cons)
2030 val = Fprogn (Fcdr (Fcdr (fun)));
2031 else
2032 val = Fbyte_code (XVECTOR (fun)->contents[COMPILED_BYTECODE],
2033 XVECTOR (fun)->contents[COMPILED_CONSTANTS],
2034 XVECTOR (fun)->contents[COMPILED_STACK_DEPTH]);
2035 return unbind_to (count, val);
2036 }
2037 \f
2038 void
2039 grow_specpdl ()
2040 {
2041 register int count = specpdl_ptr - specpdl;
2042 if (specpdl_size >= max_specpdl_size)
2043 {
2044 if (max_specpdl_size < 400)
2045 max_specpdl_size = 400;
2046 if (specpdl_size >= max_specpdl_size)
2047 {
2048 Fsignal (Qerror,
2049 Fcons (build_string ("Variable binding depth exceeds max-specpdl-size"), Qnil));
2050 max_specpdl_size *= 2;
2051 }
2052 }
2053 specpdl_size *= 2;
2054 if (specpdl_size > max_specpdl_size)
2055 specpdl_size = max_specpdl_size;
2056 specpdl = (struct specbinding *) xrealloc (specpdl, specpdl_size * sizeof (struct specbinding));
2057 specpdl_ptr = specpdl + count;
2058 }
2059
2060 void
2061 specbind (symbol, value)
2062 Lisp_Object symbol, value;
2063 {
2064 extern void store_symval_forwarding (); /* in eval.c */
2065 Lisp_Object ovalue;
2066
2067 CHECK_SYMBOL (symbol, 0);
2068
2069 if (specpdl_ptr == specpdl + specpdl_size)
2070 grow_specpdl ();
2071 specpdl_ptr->symbol = symbol;
2072 specpdl_ptr->func = 0;
2073 ovalue = XSYMBOL (symbol)->value;
2074 specpdl_ptr->old_value = EQ (ovalue, Qunbound) ? Qunbound : Fsymbol_value (symbol);
2075 specpdl_ptr++;
2076 if (XTYPE (ovalue) == Lisp_Buffer_Objfwd)
2077 store_symval_forwarding (symbol, ovalue, value);
2078 else
2079 Fset (symbol, value);
2080 }
2081
2082 void
2083 record_unwind_protect (function, arg)
2084 Lisp_Object (*function)();
2085 Lisp_Object arg;
2086 {
2087 if (specpdl_ptr == specpdl + specpdl_size)
2088 grow_specpdl ();
2089 specpdl_ptr->func = function;
2090 specpdl_ptr->symbol = Qnil;
2091 specpdl_ptr->old_value = arg;
2092 specpdl_ptr++;
2093 }
2094
2095 Lisp_Object
2096 unbind_to (count, value)
2097 int count;
2098 Lisp_Object value;
2099 {
2100 int quitf = !NILP (Vquit_flag);
2101 struct gcpro gcpro1;
2102
2103 GCPRO1 (value);
2104
2105 Vquit_flag = Qnil;
2106
2107 while (specpdl_ptr != specpdl + count)
2108 {
2109 --specpdl_ptr;
2110 if (specpdl_ptr->func != 0)
2111 (*specpdl_ptr->func) (specpdl_ptr->old_value);
2112 /* Note that a "binding" of nil is really an unwind protect,
2113 so in that case the "old value" is a list of forms to evaluate. */
2114 else if (NILP (specpdl_ptr->symbol))
2115 Fprogn (specpdl_ptr->old_value);
2116 else
2117 Fset (specpdl_ptr->symbol, specpdl_ptr->old_value);
2118 }
2119 if (NILP (Vquit_flag) && quitf) Vquit_flag = Qt;
2120
2121 UNGCPRO;
2122
2123 return value;
2124 }
2125 \f
2126 #if 0
2127
2128 /* Get the value of symbol's global binding, even if that binding
2129 is not now dynamically visible. */
2130
2131 Lisp_Object
2132 top_level_value (symbol)
2133 Lisp_Object symbol;
2134 {
2135 register struct specbinding *ptr = specpdl;
2136
2137 CHECK_SYMBOL (symbol, 0);
2138 for (; ptr != specpdl_ptr; ptr++)
2139 {
2140 if (EQ (ptr->symbol, symbol))
2141 return ptr->old_value;
2142 }
2143 return Fsymbol_value (symbol);
2144 }
2145
2146 Lisp_Object
2147 top_level_set (symbol, newval)
2148 Lisp_Object symbol, newval;
2149 {
2150 register struct specbinding *ptr = specpdl;
2151
2152 CHECK_SYMBOL (symbol, 0);
2153 for (; ptr != specpdl_ptr; ptr++)
2154 {
2155 if (EQ (ptr->symbol, symbol))
2156 {
2157 ptr->old_value = newval;
2158 return newval;
2159 }
2160 }
2161 return Fset (symbol, newval);
2162 }
2163
2164 #endif /* 0 */
2165 \f
2166 DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
2167 "Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.\n\
2168 The debugger is entered when that frame exits, if the flag is non-nil.")
2169 (level, flag)
2170 Lisp_Object level, flag;
2171 {
2172 register struct backtrace *backlist = backtrace_list;
2173 register int i;
2174
2175 CHECK_NUMBER (level, 0);
2176
2177 for (i = 0; backlist && i < XINT (level); i++)
2178 {
2179 backlist = backlist->next;
2180 }
2181
2182 if (backlist)
2183 backlist->debug_on_exit = !NILP (flag);
2184
2185 return flag;
2186 }
2187
2188 DEFUN ("backtrace", Fbacktrace, Sbacktrace, 0, 0, "",
2189 "Print a trace of Lisp function calls currently active.\n\
2190 Output stream used is value of `standard-output'.")
2191 ()
2192 {
2193 register struct backtrace *backlist = backtrace_list;
2194 register int i;
2195 Lisp_Object tail;
2196 Lisp_Object tem;
2197 extern Lisp_Object Vprint_level;
2198 struct gcpro gcpro1;
2199
2200 XFASTINT (Vprint_level) = 3;
2201
2202 tail = Qnil;
2203 GCPRO1 (tail);
2204
2205 while (backlist)
2206 {
2207 write_string (backlist->debug_on_exit ? "* " : " ", 2);
2208 if (backlist->nargs == UNEVALLED)
2209 {
2210 Fprin1 (Fcons (*backlist->function, *backlist->args), Qnil);
2211 }
2212 else
2213 {
2214 tem = *backlist->function;
2215 Fprin1 (tem, Qnil); /* This can QUIT */
2216 write_string ("(", -1);
2217 if (backlist->nargs == MANY)
2218 {
2219 for (tail = *backlist->args, i = 0;
2220 !NILP (tail);
2221 tail = Fcdr (tail), i++)
2222 {
2223 if (i) write_string (" ", -1);
2224 Fprin1 (Fcar (tail), Qnil);
2225 }
2226 }
2227 else
2228 {
2229 for (i = 0; i < backlist->nargs; i++)
2230 {
2231 if (i) write_string (" ", -1);
2232 Fprin1 (backlist->args[i], Qnil);
2233 }
2234 }
2235 }
2236 write_string (")\n", -1);
2237 backlist = backlist->next;
2238 }
2239
2240 Vprint_level = Qnil;
2241 UNGCPRO;
2242 return Qnil;
2243 }
2244
2245 DEFUN ("backtrace-frame", Fbacktrace_frame, Sbacktrace_frame, 1, 1, "",
2246 "Return the function and arguments N frames up from current execution point.\n\
2247 If that frame has not evaluated the arguments yet (or is a special form),\n\
2248 the value is (nil FUNCTION ARG-FORMS...).\n\
2249 If that frame has evaluated its arguments and called its function already,\n\
2250 the value is (t FUNCTION ARG-VALUES...).\n\
2251 A &rest arg is represented as the tail of the list ARG-VALUES.\n\
2252 FUNCTION is whatever was supplied as car of evaluated list,\n\
2253 or a lambda expression for macro calls.\n\
2254 If N is more than the number of frames, the value is nil.")
2255 (nframes)
2256 Lisp_Object nframes;
2257 {
2258 register struct backtrace *backlist = backtrace_list;
2259 register int i;
2260 Lisp_Object tem;
2261
2262 CHECK_NATNUM (nframes, 0);
2263
2264 /* Find the frame requested. */
2265 for (i = 0; i < XFASTINT (nframes); i++)
2266 backlist = backlist->next;
2267
2268 if (!backlist)
2269 return Qnil;
2270 if (backlist->nargs == UNEVALLED)
2271 return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
2272 else
2273 {
2274 if (backlist->nargs == MANY)
2275 tem = *backlist->args;
2276 else
2277 tem = Flist (backlist->nargs, backlist->args);
2278
2279 return Fcons (Qt, Fcons (*backlist->function, tem));
2280 }
2281 }
2282 \f
2283 syms_of_eval ()
2284 {
2285 DEFVAR_INT ("max-specpdl-size", &max_specpdl_size,
2286 "Limit on number of Lisp variable bindings & unwind-protects before error.");
2287
2288 DEFVAR_INT ("max-lisp-eval-depth", &max_lisp_eval_depth,
2289 "Limit on depth in `eval', `apply' and `funcall' before error.\n\
2290 This limit is to catch infinite recursions for you before they cause\n\
2291 actual stack overflow in C, which would be fatal for Emacs.\n\
2292 You can safely make it considerably larger than its default value,\n\
2293 if that proves inconveniently small.");
2294
2295 DEFVAR_LISP ("quit-flag", &Vquit_flag,
2296 "Non-nil causes `eval' to abort, unless `inhibit-quit' is non-nil.\n\
2297 Typing C-G sets `quit-flag' non-nil, regardless of `inhibit-quit'.");
2298 Vquit_flag = Qnil;
2299
2300 DEFVAR_LISP ("inhibit-quit", &Vinhibit_quit,
2301 "Non-nil inhibits C-g quitting from happening immediately.\n\
2302 Note that `quit-flag' will still be set by typing C-g,\n\
2303 so a quit will be signalled as soon as `inhibit-quit' is nil.\n\
2304 To prevent this happening, set `quit-flag' to nil\n\
2305 before making `inhibit-quit' nil.");
2306 Vinhibit_quit = Qnil;
2307
2308 Qinhibit_quit = intern ("inhibit-quit");
2309 staticpro (&Qinhibit_quit);
2310
2311 Qautoload = intern ("autoload");
2312 staticpro (&Qautoload);
2313
2314 Qdebug_on_error = intern ("debug-on-error");
2315 staticpro (&Qdebug_on_error);
2316
2317 Qmacro = intern ("macro");
2318 staticpro (&Qmacro);
2319
2320 /* Note that the process handling also uses Qexit, but we don't want
2321 to staticpro it twice, so we just do it here. */
2322 Qexit = intern ("exit");
2323 staticpro (&Qexit);
2324
2325 Qinteractive = intern ("interactive");
2326 staticpro (&Qinteractive);
2327
2328 Qcommandp = intern ("commandp");
2329 staticpro (&Qcommandp);
2330
2331 Qdefun = intern ("defun");
2332 staticpro (&Qdefun);
2333
2334 Qand_rest = intern ("&rest");
2335 staticpro (&Qand_rest);
2336
2337 Qand_optional = intern ("&optional");
2338 staticpro (&Qand_optional);
2339
2340 DEFVAR_LISP ("stack-trace-on-error", &Vstack_trace_on_error,
2341 "*Non-nil means automatically display a backtrace buffer\n\
2342 after any error that is handled by the editor command loop.\n\
2343 If the value is a list, an error only means to display a backtrace\n\
2344 if one of its condition symbols appears in the list.");
2345 Vstack_trace_on_error = Qnil;
2346
2347 DEFVAR_LISP ("debug-on-error", &Vdebug_on_error,
2348 "*Non-nil means enter debugger if an error is signaled.\n\
2349 Does not apply to errors handled by `condition-case'.\n\
2350 If the value is a list, an error only means to enter the debugger\n\
2351 if one of its condition symbols appears in the list.\n\
2352 See also variable `debug-on-quit'.");
2353 Vdebug_on_error = Qnil;
2354
2355 DEFVAR_BOOL ("debug-on-quit", &debug_on_quit,
2356 "*Non-nil means enter debugger if quit is signaled (C-G, for example).\n\
2357 Does not apply if quit is handled by a `condition-case'.");
2358 debug_on_quit = 0;
2359
2360 DEFVAR_BOOL ("debug-on-next-call", &debug_on_next_call,
2361 "Non-nil means enter debugger before next `eval', `apply' or `funcall'.");
2362
2363 DEFVAR_LISP ("debugger", &Vdebugger,
2364 "Function to call to invoke debugger.\n\
2365 If due to frame exit, args are `exit' and the value being returned;\n\
2366 this function's value will be returned instead of that.\n\
2367 If due to error, args are `error' and a list of the args to `signal'.\n\
2368 If due to `apply' or `funcall' entry, one arg, `lambda'.\n\
2369 If due to `eval' entry, one arg, t.");
2370 Vdebugger = Qnil;
2371
2372 Qmocklisp_arguments = intern ("mocklisp-arguments");
2373 staticpro (&Qmocklisp_arguments);
2374 DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments,
2375 "While in a mocklisp function, the list of its unevaluated args.");
2376 Vmocklisp_arguments = Qt;
2377
2378 DEFVAR_LISP ("run-hooks", &Vrun_hooks,
2379 "Set to the function `run-hooks', if that function has been defined.\n\
2380 Otherwise, nil (in a bare Emacs without preloaded Lisp code).");
2381 Vrun_hooks = Qnil;
2382
2383 staticpro (&Vautoload_queue);
2384 Vautoload_queue = Qnil;
2385
2386 defsubr (&Sor);
2387 defsubr (&Sand);
2388 defsubr (&Sif);
2389 defsubr (&Scond);
2390 defsubr (&Sprogn);
2391 defsubr (&Sprog1);
2392 defsubr (&Sprog2);
2393 defsubr (&Ssetq);
2394 defsubr (&Squote);
2395 defsubr (&Sfunction);
2396 defsubr (&Sdefun);
2397 defsubr (&Sdefmacro);
2398 defsubr (&Sdefvar);
2399 defsubr (&Sdefconst);
2400 defsubr (&Suser_variable_p);
2401 defsubr (&Slet);
2402 defsubr (&SletX);
2403 defsubr (&Swhile);
2404 defsubr (&Smacroexpand);
2405 defsubr (&Scatch);
2406 defsubr (&Sthrow);
2407 defsubr (&Sunwind_protect);
2408 defsubr (&Scondition_case);
2409 defsubr (&Ssignal);
2410 defsubr (&Sinteractive_p);
2411 defsubr (&Scommandp);
2412 defsubr (&Sautoload);
2413 defsubr (&Seval);
2414 defsubr (&Sapply);
2415 defsubr (&Sfuncall);
2416 defsubr (&Sbacktrace_debug);
2417 defsubr (&Sbacktrace);
2418 defsubr (&Sbacktrace_frame);
2419 }