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