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