(displayed-month, displayed-year): Move declarations where needed.
[emacs.git] / src / data.c
blob6f1256786eca1347db38a526a0a6da758046b588
1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
24 #include <config.h>
25 #include <signal.h>
26 #include <stdio.h>
27 #include "lisp.h"
28 #include "puresize.h"
29 #include "character.h"
30 #include "buffer.h"
31 #include "keyboard.h"
32 #include "frame.h"
33 #include "syssignal.h"
34 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
36 #ifdef STDC_HEADERS
37 #include <float.h>
38 #endif
40 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
41 #ifndef IEEE_FLOATING_POINT
42 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
43 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
44 #define IEEE_FLOATING_POINT 1
45 #else
46 #define IEEE_FLOATING_POINT 0
47 #endif
48 #endif
50 /* Work around a problem that happens because math.h on hpux 7
51 defines two static variables--which, in Emacs, are not really static,
52 because `static' is defined as nothing. The problem is that they are
53 here, in floatfns.c, and in lread.c.
54 These macros prevent the name conflict. */
55 #if defined (HPUX) && !defined (HPUX8)
56 #define _MAXLDBL data_c_maxldbl
57 #define _NMAXLDBL data_c_nmaxldbl
58 #endif
60 #include <math.h>
62 #if !defined (atof)
63 extern double atof ();
64 #endif /* !atof */
66 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
67 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
68 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
69 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
70 Lisp_Object Qcyclic_variable_indirection, Qcircular_list;
71 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
72 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
73 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
74 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
75 Lisp_Object Qtext_read_only;
77 Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
78 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
79 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
80 Lisp_Object Qbuffer_or_string_p, Qkeywordp;
81 Lisp_Object Qboundp, Qfboundp;
82 Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
84 Lisp_Object Qcdr;
85 Lisp_Object Qad_advice_info, Qad_activate_internal;
87 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
88 Lisp_Object Qoverflow_error, Qunderflow_error;
90 Lisp_Object Qfloatp;
91 Lisp_Object Qnumberp, Qnumber_or_marker_p;
93 Lisp_Object Qinteger;
94 static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
95 static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
96 Lisp_Object Qprocess;
97 static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
98 static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
99 static Lisp_Object Qsubrp, Qmany, Qunevalled;
101 static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object));
103 Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
106 void
107 circular_list_error (list)
108 Lisp_Object list;
110 xsignal (Qcircular_list, list);
114 Lisp_Object
115 wrong_type_argument (predicate, value)
116 register Lisp_Object predicate, value;
118 /* If VALUE is not even a valid Lisp object, abort here
119 where we can get a backtrace showing where it came from. */
120 if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
121 abort ();
123 xsignal2 (Qwrong_type_argument, predicate, value);
126 void
127 pure_write_error ()
129 error ("Attempt to modify read-only object");
132 void
133 args_out_of_range (a1, a2)
134 Lisp_Object a1, a2;
136 xsignal2 (Qargs_out_of_range, a1, a2);
139 void
140 args_out_of_range_3 (a1, a2, a3)
141 Lisp_Object a1, a2, a3;
143 xsignal3 (Qargs_out_of_range, a1, a2, a3);
146 /* On some machines, XINT needs a temporary location.
147 Here it is, in case it is needed. */
149 int sign_extend_temp;
151 /* On a few machines, XINT can only be done by calling this. */
154 sign_extend_lisp_int (num)
155 EMACS_INT num;
157 if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
158 return num | (((EMACS_INT) (-1)) << VALBITS);
159 else
160 return num & ((((EMACS_INT) 1) << VALBITS) - 1);
163 /* Data type predicates */
165 DEFUN ("eq", Feq, Seq, 2, 2, 0,
166 doc: /* Return t if the two args are the same Lisp object. */)
167 (obj1, obj2)
168 Lisp_Object obj1, obj2;
170 if (EQ (obj1, obj2))
171 return Qt;
172 return Qnil;
175 DEFUN ("null", Fnull, Snull, 1, 1, 0,
176 doc: /* Return t if OBJECT is nil. */)
177 (object)
178 Lisp_Object object;
180 if (NILP (object))
181 return Qt;
182 return Qnil;
185 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
186 doc: /* Return a symbol representing the type of OBJECT.
187 The symbol returned names the object's basic type;
188 for example, (type-of 1) returns `integer'. */)
189 (object)
190 Lisp_Object object;
192 switch (XTYPE (object))
194 case Lisp_Int:
195 return Qinteger;
197 case Lisp_Symbol:
198 return Qsymbol;
200 case Lisp_String:
201 return Qstring;
203 case Lisp_Cons:
204 return Qcons;
206 case Lisp_Misc:
207 switch (XMISCTYPE (object))
209 case Lisp_Misc_Marker:
210 return Qmarker;
211 case Lisp_Misc_Overlay:
212 return Qoverlay;
213 case Lisp_Misc_Float:
214 return Qfloat;
216 abort ();
218 case Lisp_Vectorlike:
219 if (WINDOW_CONFIGURATIONP (object))
220 return Qwindow_configuration;
221 if (PROCESSP (object))
222 return Qprocess;
223 if (WINDOWP (object))
224 return Qwindow;
225 if (SUBRP (object))
226 return Qsubr;
227 if (COMPILEDP (object))
228 return Qcompiled_function;
229 if (BUFFERP (object))
230 return Qbuffer;
231 if (CHAR_TABLE_P (object))
232 return Qchar_table;
233 if (BOOL_VECTOR_P (object))
234 return Qbool_vector;
235 if (FRAMEP (object))
236 return Qframe;
237 if (HASH_TABLE_P (object))
238 return Qhash_table;
239 return Qvector;
241 case Lisp_Float:
242 return Qfloat;
244 default:
245 abort ();
249 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
250 doc: /* Return t if OBJECT is a cons cell. */)
251 (object)
252 Lisp_Object object;
254 if (CONSP (object))
255 return Qt;
256 return Qnil;
259 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
260 doc: /* Return t if OBJECT is not a cons cell. This includes nil. */)
261 (object)
262 Lisp_Object object;
264 if (CONSP (object))
265 return Qnil;
266 return Qt;
269 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
270 doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
271 Otherwise, return nil. */)
272 (object)
273 Lisp_Object object;
275 if (CONSP (object) || NILP (object))
276 return Qt;
277 return Qnil;
280 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
281 doc: /* Return t if OBJECT is not a list. Lists include nil. */)
282 (object)
283 Lisp_Object object;
285 if (CONSP (object) || NILP (object))
286 return Qnil;
287 return Qt;
290 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
291 doc: /* Return t if OBJECT is a symbol. */)
292 (object)
293 Lisp_Object object;
295 if (SYMBOLP (object))
296 return Qt;
297 return Qnil;
300 /* Define this in C to avoid unnecessarily consing up the symbol
301 name. */
302 DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
303 doc: /* Return t if OBJECT is a keyword.
304 This means that it is a symbol with a print name beginning with `:'
305 interned in the initial obarray. */)
306 (object)
307 Lisp_Object object;
309 if (SYMBOLP (object)
310 && SREF (SYMBOL_NAME (object), 0) == ':'
311 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
312 return Qt;
313 return Qnil;
316 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
317 doc: /* Return t if OBJECT is a vector. */)
318 (object)
319 Lisp_Object object;
321 if (VECTORP (object))
322 return Qt;
323 return Qnil;
326 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
327 doc: /* Return t if OBJECT is a string. */)
328 (object)
329 Lisp_Object object;
331 if (STRINGP (object))
332 return Qt;
333 return Qnil;
336 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
337 1, 1, 0,
338 doc: /* Return t if OBJECT is a multibyte string. */)
339 (object)
340 Lisp_Object object;
342 if (STRINGP (object) && STRING_MULTIBYTE (object))
343 return Qt;
344 return Qnil;
347 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
348 doc: /* Return t if OBJECT is a char-table. */)
349 (object)
350 Lisp_Object object;
352 if (CHAR_TABLE_P (object))
353 return Qt;
354 return Qnil;
357 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
358 Svector_or_char_table_p, 1, 1, 0,
359 doc: /* Return t if OBJECT is a char-table or vector. */)
360 (object)
361 Lisp_Object object;
363 if (VECTORP (object) || CHAR_TABLE_P (object))
364 return Qt;
365 return Qnil;
368 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
369 doc: /* Return t if OBJECT is a bool-vector. */)
370 (object)
371 Lisp_Object object;
373 if (BOOL_VECTOR_P (object))
374 return Qt;
375 return Qnil;
378 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
379 doc: /* Return t if OBJECT is an array (string or vector). */)
380 (object)
381 Lisp_Object object;
383 if (ARRAYP (object))
384 return Qt;
385 return Qnil;
388 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
389 doc: /* Return t if OBJECT is a sequence (list or array). */)
390 (object)
391 register Lisp_Object object;
393 if (CONSP (object) || NILP (object) || ARRAYP (object))
394 return Qt;
395 return Qnil;
398 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
399 doc: /* Return t if OBJECT is an editor buffer. */)
400 (object)
401 Lisp_Object object;
403 if (BUFFERP (object))
404 return Qt;
405 return Qnil;
408 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
409 doc: /* Return t if OBJECT is a marker (editor pointer). */)
410 (object)
411 Lisp_Object object;
413 if (MARKERP (object))
414 return Qt;
415 return Qnil;
418 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
419 doc: /* Return t if OBJECT is a built-in function. */)
420 (object)
421 Lisp_Object object;
423 if (SUBRP (object))
424 return Qt;
425 return Qnil;
428 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
429 1, 1, 0,
430 doc: /* Return t if OBJECT is a byte-compiled function object. */)
431 (object)
432 Lisp_Object object;
434 if (COMPILEDP (object))
435 return Qt;
436 return Qnil;
439 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
440 doc: /* Return t if OBJECT is a character or a string. */)
441 (object)
442 register Lisp_Object object;
444 if (CHARACTERP (object) || STRINGP (object))
445 return Qt;
446 return Qnil;
449 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
450 doc: /* Return t if OBJECT is an integer. */)
451 (object)
452 Lisp_Object object;
454 if (INTEGERP (object))
455 return Qt;
456 return Qnil;
459 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
460 doc: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
461 (object)
462 register Lisp_Object object;
464 if (MARKERP (object) || INTEGERP (object))
465 return Qt;
466 return Qnil;
469 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
470 doc: /* Return t if OBJECT is a nonnegative integer. */)
471 (object)
472 Lisp_Object object;
474 if (NATNUMP (object))
475 return Qt;
476 return Qnil;
479 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
480 doc: /* Return t if OBJECT is a number (floating point or integer). */)
481 (object)
482 Lisp_Object object;
484 if (NUMBERP (object))
485 return Qt;
486 else
487 return Qnil;
490 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
491 Snumber_or_marker_p, 1, 1, 0,
492 doc: /* Return t if OBJECT is a number or a marker. */)
493 (object)
494 Lisp_Object object;
496 if (NUMBERP (object) || MARKERP (object))
497 return Qt;
498 return Qnil;
501 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
502 doc: /* Return t if OBJECT is a floating point number. */)
503 (object)
504 Lisp_Object object;
506 if (FLOATP (object))
507 return Qt;
508 return Qnil;
512 /* Extract and set components of lists */
514 DEFUN ("car", Fcar, Scar, 1, 1, 0,
515 doc: /* Return the car of LIST. If arg is nil, return nil.
516 Error if arg is not nil and not a cons cell. See also `car-safe'.
518 See Info node `(elisp)Cons Cells' for a discussion of related basic
519 Lisp concepts such as car, cdr, cons cell and list. */)
520 (list)
521 register Lisp_Object list;
523 return CAR (list);
526 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
527 doc: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
528 (object)
529 Lisp_Object object;
531 return CAR_SAFE (object);
534 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
535 doc: /* Return the cdr of LIST. If arg is nil, return nil.
536 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
538 See Info node `(elisp)Cons Cells' for a discussion of related basic
539 Lisp concepts such as cdr, car, cons cell and list. */)
540 (list)
541 register Lisp_Object list;
543 return CDR (list);
546 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
547 doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
548 (object)
549 Lisp_Object object;
551 return CDR_SAFE (object);
554 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
555 doc: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
556 (cell, newcar)
557 register Lisp_Object cell, newcar;
559 CHECK_CONS (cell);
560 CHECK_IMPURE (cell);
561 XSETCAR (cell, newcar);
562 return newcar;
565 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
566 doc: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
567 (cell, newcdr)
568 register Lisp_Object cell, newcdr;
570 CHECK_CONS (cell);
571 CHECK_IMPURE (cell);
572 XSETCDR (cell, newcdr);
573 return newcdr;
576 /* Extract and set components of symbols */
578 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
579 doc: /* Return t if SYMBOL's value is not void. */)
580 (symbol)
581 register Lisp_Object symbol;
583 Lisp_Object valcontents;
584 CHECK_SYMBOL (symbol);
586 valcontents = SYMBOL_VALUE (symbol);
588 if (BUFFER_LOCAL_VALUEP (valcontents))
589 valcontents = swap_in_symval_forwarding (symbol, valcontents);
591 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
594 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
595 doc: /* Return t if SYMBOL's function definition is not void. */)
596 (symbol)
597 register Lisp_Object symbol;
599 CHECK_SYMBOL (symbol);
600 return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
603 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
604 doc: /* Make SYMBOL's value be void.
605 Return SYMBOL. */)
606 (symbol)
607 register Lisp_Object symbol;
609 CHECK_SYMBOL (symbol);
610 if (SYMBOL_CONSTANT_P (symbol))
611 xsignal1 (Qsetting_constant, symbol);
612 Fset (symbol, Qunbound);
613 return symbol;
616 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
617 doc: /* Make SYMBOL's function definition be void.
618 Return SYMBOL. */)
619 (symbol)
620 register Lisp_Object symbol;
622 CHECK_SYMBOL (symbol);
623 if (NILP (symbol) || EQ (symbol, Qt))
624 xsignal1 (Qsetting_constant, symbol);
625 XSYMBOL (symbol)->function = Qunbound;
626 return symbol;
629 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
630 doc: /* Return SYMBOL's function definition. Error if that is void. */)
631 (symbol)
632 register Lisp_Object symbol;
634 CHECK_SYMBOL (symbol);
635 if (!EQ (XSYMBOL (symbol)->function, Qunbound))
636 return XSYMBOL (symbol)->function;
637 xsignal1 (Qvoid_function, symbol);
640 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
641 doc: /* Return SYMBOL's property list. */)
642 (symbol)
643 register Lisp_Object symbol;
645 CHECK_SYMBOL (symbol);
646 return XSYMBOL (symbol)->plist;
649 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
650 doc: /* Return SYMBOL's name, a string. */)
651 (symbol)
652 register Lisp_Object symbol;
654 register Lisp_Object name;
656 CHECK_SYMBOL (symbol);
657 name = SYMBOL_NAME (symbol);
658 return name;
661 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
662 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
663 (symbol, definition)
664 register Lisp_Object symbol, definition;
666 register Lisp_Object function;
668 CHECK_SYMBOL (symbol);
669 if (NILP (symbol) || EQ (symbol, Qt))
670 xsignal1 (Qsetting_constant, symbol);
672 function = XSYMBOL (symbol)->function;
674 if (!NILP (Vautoload_queue) && !EQ (function, Qunbound))
675 Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
677 if (CONSP (function) && EQ (XCAR (function), Qautoload))
678 Fput (symbol, Qautoload, XCDR (function));
680 XSYMBOL (symbol)->function = definition;
681 /* Handle automatic advice activation */
682 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
684 call2 (Qad_activate_internal, symbol, Qnil);
685 definition = XSYMBOL (symbol)->function;
687 return definition;
690 extern Lisp_Object Qfunction_documentation;
692 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
693 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
694 Associates the function with the current load file, if any.
695 The optional third argument DOCSTRING specifies the documentation string
696 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
697 determined by DEFINITION. */)
698 (symbol, definition, docstring)
699 register Lisp_Object symbol, definition, docstring;
701 CHECK_SYMBOL (symbol);
702 if (CONSP (XSYMBOL (symbol)->function)
703 && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
704 LOADHIST_ATTACH (Fcons (Qt, symbol));
705 definition = Ffset (symbol, definition);
706 LOADHIST_ATTACH (Fcons (Qdefun, symbol));
707 if (!NILP (docstring))
708 Fput (symbol, Qfunction_documentation, docstring);
709 return definition;
712 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
713 doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
714 (symbol, newplist)
715 register Lisp_Object symbol, newplist;
717 CHECK_SYMBOL (symbol);
718 XSYMBOL (symbol)->plist = newplist;
719 return newplist;
722 DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
723 doc: /* Return minimum and maximum number of args allowed for SUBR.
724 SUBR must be a built-in function.
725 The returned value is a pair (MIN . MAX). MIN is the minimum number
726 of args. MAX is the maximum number or the symbol `many', for a
727 function with `&rest' args, or `unevalled' for a special form. */)
728 (subr)
729 Lisp_Object subr;
731 short minargs, maxargs;
732 CHECK_SUBR (subr);
733 minargs = XSUBR (subr)->min_args;
734 maxargs = XSUBR (subr)->max_args;
735 if (maxargs == MANY)
736 return Fcons (make_number (minargs), Qmany);
737 else if (maxargs == UNEVALLED)
738 return Fcons (make_number (minargs), Qunevalled);
739 else
740 return Fcons (make_number (minargs), make_number (maxargs));
743 DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
744 doc: /* Return name of subroutine SUBR.
745 SUBR must be a built-in function. */)
746 (subr)
747 Lisp_Object subr;
749 const char *name;
750 CHECK_SUBR (subr);
751 name = XSUBR (subr)->symbol_name;
752 return make_string (name, strlen (name));
755 DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
756 doc: /* Return the interactive form of CMD or nil if none.
757 If CMD is not a command, the return value is nil.
758 Value, if non-nil, is a list \(interactive SPEC). */)
759 (cmd)
760 Lisp_Object cmd;
762 Lisp_Object fun = indirect_function (cmd); /* Check cycles. */
764 if (NILP (fun) || EQ (fun, Qunbound))
765 return Qnil;
767 /* Use an `interactive-form' property if present, analogous to the
768 function-documentation property. */
769 fun = cmd;
770 while (SYMBOLP (fun))
772 Lisp_Object tmp = Fget (fun, intern ("interactive-form"));
773 if (!NILP (tmp))
774 return tmp;
775 else
776 fun = Fsymbol_function (fun);
779 if (SUBRP (fun))
781 char *spec = XSUBR (fun)->intspec;
782 if (spec)
783 return list2 (Qinteractive,
784 (*spec != '(') ? build_string (spec) :
785 Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
787 else if (COMPILEDP (fun))
789 if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
790 return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
792 else if (CONSP (fun))
794 Lisp_Object funcar = XCAR (fun);
795 if (EQ (funcar, Qlambda))
796 return Fassq (Qinteractive, Fcdr (XCDR (fun)));
797 else if (EQ (funcar, Qautoload))
799 struct gcpro gcpro1;
800 GCPRO1 (cmd);
801 do_autoload (fun, cmd);
802 UNGCPRO;
803 return Finteractive_form (cmd);
806 return Qnil;
810 /***********************************************************************
811 Getting and Setting Values of Symbols
812 ***********************************************************************/
814 /* Return the symbol holding SYMBOL's value. Signal
815 `cyclic-variable-indirection' if SYMBOL's chain of variable
816 indirections contains a loop. */
818 Lisp_Object
819 indirect_variable (symbol)
820 Lisp_Object symbol;
822 Lisp_Object tortoise, hare;
824 hare = tortoise = symbol;
826 while (XSYMBOL (hare)->indirect_variable)
828 hare = XSYMBOL (hare)->value;
829 if (!XSYMBOL (hare)->indirect_variable)
830 break;
832 hare = XSYMBOL (hare)->value;
833 tortoise = XSYMBOL (tortoise)->value;
835 if (EQ (hare, tortoise))
836 xsignal1 (Qcyclic_variable_indirection, symbol);
839 return hare;
843 DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
844 doc: /* Return the variable at the end of OBJECT's variable chain.
845 If OBJECT is a symbol, follow all variable indirections and return the final
846 variable. If OBJECT is not a symbol, just return it.
847 Signal a cyclic-variable-indirection error if there is a loop in the
848 variable chain of symbols. */)
849 (object)
850 Lisp_Object object;
852 if (SYMBOLP (object))
853 object = indirect_variable (object);
854 return object;
858 /* Given the raw contents of a symbol value cell,
859 return the Lisp value of the symbol.
860 This does not handle buffer-local variables; use
861 swap_in_symval_forwarding for that. */
863 Lisp_Object
864 do_symval_forwarding (valcontents)
865 register Lisp_Object valcontents;
867 register Lisp_Object val;
868 if (MISCP (valcontents))
869 switch (XMISCTYPE (valcontents))
871 case Lisp_Misc_Intfwd:
872 XSETINT (val, *XINTFWD (valcontents)->intvar);
873 return val;
875 case Lisp_Misc_Boolfwd:
876 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
878 case Lisp_Misc_Objfwd:
879 return *XOBJFWD (valcontents)->objvar;
881 case Lisp_Misc_Buffer_Objfwd:
882 return PER_BUFFER_VALUE (current_buffer,
883 XBUFFER_OBJFWD (valcontents)->offset);
885 case Lisp_Misc_Kboard_Objfwd:
886 /* We used to simply use current_kboard here, but from Lisp
887 code, it's value is often unexpected. It seems nicer to
888 allow constructions like this to work as intuitively expected:
890 (with-selected-frame frame
891 (define-key local-function-map "\eOP" [f1]))
893 On the other hand, this affects the semantics of
894 last-command and real-last-command, and people may rely on
895 that. I took a quick look at the Lisp codebase, and I
896 don't think anything will break. --lorentey */
897 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
898 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
900 return valcontents;
903 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
904 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
905 buffer-independent contents of the value cell: forwarded just one
906 step past the buffer-localness.
908 BUF non-zero means set the value in buffer BUF instead of the
909 current buffer. This only plays a role for per-buffer variables. */
911 void
912 store_symval_forwarding (symbol, valcontents, newval, buf)
913 Lisp_Object symbol;
914 register Lisp_Object valcontents, newval;
915 struct buffer *buf;
917 switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
919 case Lisp_Misc:
920 switch (XMISCTYPE (valcontents))
922 case Lisp_Misc_Intfwd:
923 CHECK_NUMBER (newval);
924 *XINTFWD (valcontents)->intvar = XINT (newval);
925 /* This can never happen since intvar points to an EMACS_INT
926 which is at least large enough to hold a Lisp_Object.
927 if (*XINTFWD (valcontents)->intvar != XINT (newval))
928 error ("Value out of range for variable `%s'",
929 SDATA (SYMBOL_NAME (symbol))); */
930 break;
932 case Lisp_Misc_Boolfwd:
933 *XBOOLFWD (valcontents)->boolvar = !NILP (newval);
934 break;
936 case Lisp_Misc_Objfwd:
937 *XOBJFWD (valcontents)->objvar = newval;
939 /* If this variable is a default for something stored
940 in the buffer itself, such as default-fill-column,
941 find the buffers that don't have local values for it
942 and update them. */
943 if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults
944 && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1))
946 int offset = ((char *) XOBJFWD (valcontents)->objvar
947 - (char *) &buffer_defaults);
948 int idx = PER_BUFFER_IDX (offset);
950 Lisp_Object tail;
952 if (idx <= 0)
953 break;
955 for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
957 Lisp_Object buf;
958 struct buffer *b;
960 buf = Fcdr (XCAR (tail));
961 if (!BUFFERP (buf)) continue;
962 b = XBUFFER (buf);
964 if (! PER_BUFFER_VALUE_P (b, idx))
965 PER_BUFFER_VALUE (b, offset) = newval;
968 break;
970 case Lisp_Misc_Buffer_Objfwd:
972 int offset = XBUFFER_OBJFWD (valcontents)->offset;
973 Lisp_Object type = XBUFFER_OBJFWD (valcontents)->slottype;
975 if (! NILP (type) && ! NILP (newval)
976 && XTYPE (newval) != XINT (type))
977 buffer_slot_type_mismatch (symbol, XINT (type));
979 if (buf == NULL)
980 buf = current_buffer;
981 PER_BUFFER_VALUE (buf, offset) = newval;
983 break;
985 case Lisp_Misc_Kboard_Objfwd:
987 char *base = (char *) FRAME_KBOARD (SELECTED_FRAME ());
988 char *p = base + XKBOARD_OBJFWD (valcontents)->offset;
989 *(Lisp_Object *) p = newval;
991 break;
993 default:
994 goto def;
996 break;
998 default:
999 def:
1000 valcontents = SYMBOL_VALUE (symbol);
1001 if (BUFFER_LOCAL_VALUEP (valcontents))
1002 XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval;
1003 else
1004 SET_SYMBOL_VALUE (symbol, newval);
1008 /* Set up SYMBOL to refer to its global binding.
1009 This makes it safe to alter the status of other bindings. */
1011 void
1012 swap_in_global_binding (symbol)
1013 Lisp_Object symbol;
1015 Lisp_Object valcontents = SYMBOL_VALUE (symbol);
1016 struct Lisp_Buffer_Local_Value *blv = XBUFFER_LOCAL_VALUE (valcontents);
1017 Lisp_Object cdr = blv->cdr;
1019 /* Unload the previously loaded binding. */
1020 Fsetcdr (XCAR (cdr),
1021 do_symval_forwarding (blv->realvalue));
1023 /* Select the global binding in the symbol. */
1024 XSETCAR (cdr, cdr);
1025 store_symval_forwarding (symbol, blv->realvalue, XCDR (cdr), NULL);
1027 /* Indicate that the global binding is set up now. */
1028 blv->frame = Qnil;
1029 blv->buffer = Qnil;
1030 blv->found_for_frame = 0;
1031 blv->found_for_buffer = 0;
1034 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1035 VALCONTENTS is the contents of its value cell,
1036 which points to a struct Lisp_Buffer_Local_Value.
1038 Return the value forwarded one step past the buffer-local stage.
1039 This could be another forwarding pointer. */
1041 static Lisp_Object
1042 swap_in_symval_forwarding (symbol, valcontents)
1043 Lisp_Object symbol, valcontents;
1045 register Lisp_Object tem1;
1047 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer;
1049 if (NILP (tem1)
1050 || current_buffer != XBUFFER (tem1)
1051 || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
1052 && ! EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)))
1054 if (XSYMBOL (symbol)->indirect_variable)
1055 symbol = indirect_variable (symbol);
1057 /* Unload the previously loaded binding. */
1058 tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1059 Fsetcdr (tem1,
1060 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
1061 /* Choose the new binding. */
1062 tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
1063 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
1064 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
1065 if (NILP (tem1))
1067 if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
1068 tem1 = assq_no_quit (symbol, XFRAME (selected_frame)->param_alist);
1069 if (! NILP (tem1))
1070 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
1071 else
1072 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
1074 else
1075 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
1077 /* Load the new binding. */
1078 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, tem1);
1079 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer);
1080 XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
1081 store_symval_forwarding (symbol,
1082 XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
1083 Fcdr (tem1), NULL);
1085 return XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
1088 /* Find the value of a symbol, returning Qunbound if it's not bound.
1089 This is helpful for code which just wants to get a variable's value
1090 if it has one, without signaling an error.
1091 Note that it must not be possible to quit
1092 within this function. Great care is required for this. */
1094 Lisp_Object
1095 find_symbol_value (symbol)
1096 Lisp_Object symbol;
1098 register Lisp_Object valcontents;
1099 register Lisp_Object val;
1101 CHECK_SYMBOL (symbol);
1102 valcontents = SYMBOL_VALUE (symbol);
1104 if (BUFFER_LOCAL_VALUEP (valcontents))
1105 valcontents = swap_in_symval_forwarding (symbol, valcontents);
1107 return do_symval_forwarding (valcontents);
1110 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
1111 doc: /* Return SYMBOL's value. Error if that is void. */)
1112 (symbol)
1113 Lisp_Object symbol;
1115 Lisp_Object val;
1117 val = find_symbol_value (symbol);
1118 if (!EQ (val, Qunbound))
1119 return val;
1121 xsignal1 (Qvoid_variable, symbol);
1124 DEFUN ("set", Fset, Sset, 2, 2, 0,
1125 doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1126 (symbol, newval)
1127 register Lisp_Object symbol, newval;
1129 return set_internal (symbol, newval, current_buffer, 0);
1132 /* Return 1 if SYMBOL currently has a let-binding
1133 which was made in the buffer that is now current. */
1135 static int
1136 let_shadows_buffer_binding_p (symbol)
1137 Lisp_Object symbol;
1139 volatile struct specbinding *p;
1141 for (p = specpdl_ptr - 1; p >= specpdl; p--)
1142 if (p->func == NULL
1143 && CONSP (p->symbol))
1145 Lisp_Object let_bound_symbol = XCAR (p->symbol);
1146 if ((EQ (symbol, let_bound_symbol)
1147 || (XSYMBOL (let_bound_symbol)->indirect_variable
1148 && EQ (symbol, indirect_variable (let_bound_symbol))))
1149 && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
1150 break;
1153 return p >= specpdl;
1156 /* Store the value NEWVAL into SYMBOL.
1157 If buffer-locality is an issue, BUF specifies which buffer to use.
1158 (0 stands for the current buffer.)
1160 If BINDFLAG is zero, then if this symbol is supposed to become
1161 local in every buffer where it is set, then we make it local.
1162 If BINDFLAG is nonzero, we don't do that. */
1164 Lisp_Object
1165 set_internal (symbol, newval, buf, bindflag)
1166 register Lisp_Object symbol, newval;
1167 struct buffer *buf;
1168 int bindflag;
1170 int voide = EQ (newval, Qunbound);
1172 register Lisp_Object valcontents, innercontents, tem1, current_alist_element;
1174 if (buf == 0)
1175 buf = current_buffer;
1177 /* If restoring in a dead buffer, do nothing. */
1178 if (NILP (buf->name))
1179 return newval;
1181 CHECK_SYMBOL (symbol);
1182 if (SYMBOL_CONSTANT_P (symbol)
1183 && (NILP (Fkeywordp (symbol))
1184 || !EQ (newval, SYMBOL_VALUE (symbol))))
1185 xsignal1 (Qsetting_constant, symbol);
1187 innercontents = valcontents = SYMBOL_VALUE (symbol);
1189 if (BUFFER_OBJFWDP (valcontents))
1191 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1192 int idx = PER_BUFFER_IDX (offset);
1193 if (idx > 0
1194 && !bindflag
1195 && !let_shadows_buffer_binding_p (symbol))
1196 SET_PER_BUFFER_VALUE_P (buf, idx, 1);
1198 else if (BUFFER_LOCAL_VALUEP (valcontents))
1200 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1201 if (XSYMBOL (symbol)->indirect_variable)
1202 symbol = indirect_variable (symbol);
1204 /* What binding is loaded right now? */
1205 current_alist_element
1206 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1208 /* If the current buffer is not the buffer whose binding is
1209 loaded, or if there may be frame-local bindings and the frame
1210 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1211 the default binding is loaded, the loaded binding may be the
1212 wrong one. */
1213 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
1214 || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
1215 || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
1216 && !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))
1217 /* Also unload a global binding (if the var is local_if_set). */
1218 || (EQ (XCAR (current_alist_element),
1219 current_alist_element)))
1221 /* The currently loaded binding is not necessarily valid.
1222 We need to unload it, and choose a new binding. */
1224 /* Write out `realvalue' to the old loaded binding. */
1225 Fsetcdr (current_alist_element,
1226 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
1228 /* Find the new binding. */
1229 tem1 = Fassq (symbol, buf->local_var_alist);
1230 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
1231 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
1233 if (NILP (tem1))
1235 /* This buffer still sees the default value. */
1237 /* If the variable is not local_if_set,
1238 or if this is `let' rather than `set',
1239 make CURRENT-ALIST-ELEMENT point to itself,
1240 indicating that we're seeing the default value.
1241 Likewise if the variable has been let-bound
1242 in the current buffer. */
1243 if (bindflag || !XBUFFER_LOCAL_VALUE (valcontents)->local_if_set
1244 || let_shadows_buffer_binding_p (symbol))
1246 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
1248 if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
1249 tem1 = Fassq (symbol,
1250 XFRAME (selected_frame)->param_alist);
1252 if (! NILP (tem1))
1253 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
1254 else
1255 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
1257 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1258 and we're not within a let that was made for this buffer,
1259 create a new buffer-local binding for the variable.
1260 That means, give this buffer a new assoc for a local value
1261 and load that binding. */
1262 else
1264 tem1 = Fcons (symbol, XCDR (current_alist_element));
1265 buf->local_var_alist
1266 = Fcons (tem1, buf->local_var_alist);
1270 /* Record which binding is now loaded. */
1271 XSETCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, tem1);
1273 /* Set `buffer' and `frame' slots for the binding now loaded. */
1274 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf);
1275 XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
1277 innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
1279 /* Store the new value in the cons-cell. */
1280 XSETCDR (XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr), newval);
1283 /* If storing void (making the symbol void), forward only through
1284 buffer-local indicator, not through Lisp_Objfwd, etc. */
1285 if (voide)
1286 store_symval_forwarding (symbol, Qnil, newval, buf);
1287 else
1288 store_symval_forwarding (symbol, innercontents, newval, buf);
1290 return newval;
1293 /* Access or set a buffer-local symbol's default value. */
1295 /* Return the default value of SYMBOL, but don't check for voidness.
1296 Return Qunbound if it is void. */
1298 Lisp_Object
1299 default_value (symbol)
1300 Lisp_Object symbol;
1302 register Lisp_Object valcontents;
1304 CHECK_SYMBOL (symbol);
1305 valcontents = SYMBOL_VALUE (symbol);
1307 /* For a built-in buffer-local variable, get the default value
1308 rather than letting do_symval_forwarding get the current value. */
1309 if (BUFFER_OBJFWDP (valcontents))
1311 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1312 if (PER_BUFFER_IDX (offset) != 0)
1313 return PER_BUFFER_DEFAULT (offset);
1316 /* Handle user-created local variables. */
1317 if (BUFFER_LOCAL_VALUEP (valcontents))
1319 /* If var is set up for a buffer that lacks a local value for it,
1320 the current value is nominally the default value.
1321 But the `realvalue' slot may be more up to date, since
1322 ordinary setq stores just that slot. So use that. */
1323 Lisp_Object current_alist_element, alist_element_car;
1324 current_alist_element
1325 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1326 alist_element_car = XCAR (current_alist_element);
1327 if (EQ (alist_element_car, current_alist_element))
1328 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue);
1329 else
1330 return XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1332 /* For other variables, get the current value. */
1333 return do_symval_forwarding (valcontents);
1336 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1337 doc: /* Return t if SYMBOL has a non-void default value.
1338 This is the value that is seen in buffers that do not have their own values
1339 for this variable. */)
1340 (symbol)
1341 Lisp_Object symbol;
1343 register Lisp_Object value;
1345 value = default_value (symbol);
1346 return (EQ (value, Qunbound) ? Qnil : Qt);
1349 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1350 doc: /* Return SYMBOL's default value.
1351 This is the value that is seen in buffers that do not have their own values
1352 for this variable. The default value is meaningful for variables with
1353 local bindings in certain buffers. */)
1354 (symbol)
1355 Lisp_Object symbol;
1357 register Lisp_Object value;
1359 value = default_value (symbol);
1360 if (!EQ (value, Qunbound))
1361 return value;
1363 xsignal1 (Qvoid_variable, symbol);
1366 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1367 doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1368 The default value is seen in buffers that do not have their own values
1369 for this variable. */)
1370 (symbol, value)
1371 Lisp_Object symbol, value;
1373 register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
1375 CHECK_SYMBOL (symbol);
1376 valcontents = SYMBOL_VALUE (symbol);
1378 /* Handle variables like case-fold-search that have special slots
1379 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1380 variables. */
1381 if (BUFFER_OBJFWDP (valcontents))
1383 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1384 int idx = PER_BUFFER_IDX (offset);
1386 PER_BUFFER_DEFAULT (offset) = value;
1388 /* If this variable is not always local in all buffers,
1389 set it in the buffers that don't nominally have a local value. */
1390 if (idx > 0)
1392 struct buffer *b;
1394 for (b = all_buffers; b; b = b->next)
1395 if (!PER_BUFFER_VALUE_P (b, idx))
1396 PER_BUFFER_VALUE (b, offset) = value;
1398 return value;
1401 if (!BUFFER_LOCAL_VALUEP (valcontents))
1402 return Fset (symbol, value);
1404 /* Store new value into the DEFAULT-VALUE slot. */
1405 XSETCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr, value);
1407 /* If the default binding is now loaded, set the REALVALUE slot too. */
1408 current_alist_element
1409 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1410 alist_element_buffer = Fcar (current_alist_element);
1411 if (EQ (alist_element_buffer, current_alist_element))
1412 store_symval_forwarding (symbol,
1413 XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
1414 value, NULL);
1416 return value;
1419 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
1420 doc: /* Set the default value of variable VAR to VALUE.
1421 VAR, the variable name, is literal (not evaluated);
1422 VALUE is an expression: it is evaluated and its value returned.
1423 The default value of a variable is seen in buffers
1424 that do not have their own values for the variable.
1426 More generally, you can use multiple variables and values, as in
1427 (setq-default VAR VALUE VAR VALUE...)
1428 This sets each VAR's default value to the corresponding VALUE.
1429 The VALUE for the Nth VAR can refer to the new default values
1430 of previous VARs.
1431 usage: (setq-default [VAR VALUE]...) */)
1432 (args)
1433 Lisp_Object args;
1435 register Lisp_Object args_left;
1436 register Lisp_Object val, symbol;
1437 struct gcpro gcpro1;
1439 if (NILP (args))
1440 return Qnil;
1442 args_left = args;
1443 GCPRO1 (args);
1447 val = Feval (Fcar (Fcdr (args_left)));
1448 symbol = XCAR (args_left);
1449 Fset_default (symbol, val);
1450 args_left = Fcdr (XCDR (args_left));
1452 while (!NILP (args_left));
1454 UNGCPRO;
1455 return val;
1458 /* Lisp functions for creating and removing buffer-local variables. */
1460 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1461 1, 1, "vMake Variable Buffer Local: ",
1462 doc: /* Make VARIABLE become buffer-local whenever it is set.
1463 At any time, the value for the current buffer is in effect,
1464 unless the variable has never been set in this buffer,
1465 in which case the default value is in effect.
1466 Note that binding the variable with `let', or setting it while
1467 a `let'-style binding made in this buffer is in effect,
1468 does not make the variable buffer-local. Return VARIABLE.
1470 In most cases it is better to use `make-local-variable',
1471 which makes a variable local in just one buffer.
1473 The function `default-value' gets the default value and `set-default' sets it. */)
1474 (variable)
1475 register Lisp_Object variable;
1477 register Lisp_Object tem, valcontents, newval;
1479 CHECK_SYMBOL (variable);
1480 variable = indirect_variable (variable);
1482 valcontents = SYMBOL_VALUE (variable);
1483 if (XSYMBOL (variable)->constant || KBOARD_OBJFWDP (valcontents))
1484 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
1486 if (BUFFER_OBJFWDP (valcontents))
1487 return variable;
1488 else if (BUFFER_LOCAL_VALUEP (valcontents))
1489 newval = valcontents;
1490 else
1492 if (EQ (valcontents, Qunbound))
1493 SET_SYMBOL_VALUE (variable, Qnil);
1494 tem = Fcons (Qnil, Fsymbol_value (variable));
1495 XSETCAR (tem, tem);
1496 newval = allocate_misc ();
1497 XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
1498 XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable);
1499 XBUFFER_LOCAL_VALUE (newval)->buffer = Fcurrent_buffer ();
1500 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
1501 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
1502 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
1503 XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
1504 XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
1505 SET_SYMBOL_VALUE (variable, newval);
1507 XBUFFER_LOCAL_VALUE (newval)->local_if_set = 1;
1508 return variable;
1511 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1512 1, 1, "vMake Local Variable: ",
1513 doc: /* Make VARIABLE have a separate value in the current buffer.
1514 Other buffers will continue to share a common default value.
1515 \(The buffer-local value of VARIABLE starts out as the same value
1516 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1517 Return VARIABLE.
1519 If the variable is already arranged to become local when set,
1520 this function causes a local value to exist for this buffer,
1521 just as setting the variable would do.
1523 This function returns VARIABLE, and therefore
1524 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1525 works.
1527 See also `make-variable-buffer-local'.
1529 Do not use `make-local-variable' to make a hook variable buffer-local.
1530 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1531 (variable)
1532 register Lisp_Object variable;
1534 register Lisp_Object tem, valcontents;
1536 CHECK_SYMBOL (variable);
1537 variable = indirect_variable (variable);
1539 valcontents = SYMBOL_VALUE (variable);
1540 if (XSYMBOL (variable)->constant || KBOARD_OBJFWDP (valcontents))
1541 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
1543 if ((BUFFER_LOCAL_VALUEP (valcontents)
1544 && XBUFFER_LOCAL_VALUE (valcontents)->local_if_set)
1545 || BUFFER_OBJFWDP (valcontents))
1547 tem = Fboundp (variable);
1549 /* Make sure the symbol has a local value in this particular buffer,
1550 by setting it to the same value it already has. */
1551 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1552 return variable;
1554 /* Make sure symbol is set up to hold per-buffer values. */
1555 if (!BUFFER_LOCAL_VALUEP (valcontents))
1557 Lisp_Object newval;
1558 tem = Fcons (Qnil, do_symval_forwarding (valcontents));
1559 XSETCAR (tem, tem);
1560 newval = allocate_misc ();
1561 XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
1562 XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable);
1563 XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
1564 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
1565 XBUFFER_LOCAL_VALUE (newval)->local_if_set = 0;
1566 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
1567 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
1568 XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
1569 XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
1570 SET_SYMBOL_VALUE (variable, newval);
1572 /* Make sure this buffer has its own value of symbol. */
1573 tem = Fassq (variable, current_buffer->local_var_alist);
1574 if (NILP (tem))
1576 /* Swap out any local binding for some other buffer, and make
1577 sure the current value is permanently recorded, if it's the
1578 default value. */
1579 find_symbol_value (variable);
1581 current_buffer->local_var_alist
1582 = Fcons (Fcons (variable, XCDR (XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->cdr)),
1583 current_buffer->local_var_alist);
1585 /* Make sure symbol does not think it is set up for this buffer;
1586 force it to look once again for this buffer's value. */
1588 Lisp_Object *pvalbuf;
1590 valcontents = SYMBOL_VALUE (variable);
1592 pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
1593 if (current_buffer == XBUFFER (*pvalbuf))
1594 *pvalbuf = Qnil;
1595 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
1599 /* If the symbol forwards into a C variable, then load the binding
1600 for this buffer now. If C code modifies the variable before we
1601 load the binding in, then that new value will clobber the default
1602 binding the next time we unload it. */
1603 valcontents = XBUFFER_LOCAL_VALUE (SYMBOL_VALUE (variable))->realvalue;
1604 if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
1605 swap_in_symval_forwarding (variable, SYMBOL_VALUE (variable));
1607 return variable;
1610 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1611 1, 1, "vKill Local Variable: ",
1612 doc: /* Make VARIABLE no longer have a separate value in the current buffer.
1613 From now on the default value will apply in this buffer. Return VARIABLE. */)
1614 (variable)
1615 register Lisp_Object variable;
1617 register Lisp_Object tem, valcontents;
1619 CHECK_SYMBOL (variable);
1620 variable = indirect_variable (variable);
1622 valcontents = SYMBOL_VALUE (variable);
1624 if (BUFFER_OBJFWDP (valcontents))
1626 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1627 int idx = PER_BUFFER_IDX (offset);
1629 if (idx > 0)
1631 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
1632 PER_BUFFER_VALUE (current_buffer, offset)
1633 = PER_BUFFER_DEFAULT (offset);
1635 return variable;
1638 if (!BUFFER_LOCAL_VALUEP (valcontents))
1639 return variable;
1641 /* Get rid of this buffer's alist element, if any. */
1643 tem = Fassq (variable, current_buffer->local_var_alist);
1644 if (!NILP (tem))
1645 current_buffer->local_var_alist
1646 = Fdelq (tem, current_buffer->local_var_alist);
1648 /* If the symbol is set up with the current buffer's binding
1649 loaded, recompute its value. We have to do it now, or else
1650 forwarded objects won't work right. */
1652 Lisp_Object *pvalbuf, buf;
1653 valcontents = SYMBOL_VALUE (variable);
1654 pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
1655 XSETBUFFER (buf, current_buffer);
1656 if (EQ (buf, *pvalbuf))
1658 *pvalbuf = Qnil;
1659 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
1660 find_symbol_value (variable);
1664 return variable;
1667 /* Lisp functions for creating and removing buffer-local variables. */
1669 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1670 1, 1, "vMake Variable Frame Local: ",
1671 doc: /* Enable VARIABLE to have frame-local bindings.
1672 This does not create any frame-local bindings for VARIABLE,
1673 it just makes them possible.
1675 A frame-local binding is actually a frame parameter value.
1676 If a frame F has a value for the frame parameter named VARIABLE,
1677 that also acts as a frame-local binding for VARIABLE in F--
1678 provided this function has been called to enable VARIABLE
1679 to have frame-local bindings at all.
1681 The only way to create a frame-local binding for VARIABLE in a frame
1682 is to set the VARIABLE frame parameter of that frame. See
1683 `modify-frame-parameters' for how to set frame parameters.
1685 Buffer-local bindings take precedence over frame-local bindings. */)
1686 (variable)
1687 register Lisp_Object variable;
1689 register Lisp_Object tem, valcontents, newval;
1691 CHECK_SYMBOL (variable);
1692 variable = indirect_variable (variable);
1694 valcontents = SYMBOL_VALUE (variable);
1695 if (XSYMBOL (variable)->constant || KBOARD_OBJFWDP (valcontents)
1696 || BUFFER_OBJFWDP (valcontents))
1697 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
1699 if (BUFFER_LOCAL_VALUEP (valcontents))
1701 XBUFFER_LOCAL_VALUE (valcontents)->check_frame = 1;
1702 return variable;
1705 if (EQ (valcontents, Qunbound))
1706 SET_SYMBOL_VALUE (variable, Qnil);
1707 tem = Fcons (Qnil, Fsymbol_value (variable));
1708 XSETCAR (tem, tem);
1709 newval = allocate_misc ();
1710 XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
1711 XBUFFER_LOCAL_VALUE (newval)->realvalue = SYMBOL_VALUE (variable);
1712 XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
1713 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
1714 XBUFFER_LOCAL_VALUE (newval)->local_if_set = 0;
1715 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
1716 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
1717 XBUFFER_LOCAL_VALUE (newval)->check_frame = 1;
1718 XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
1719 SET_SYMBOL_VALUE (variable, newval);
1720 return variable;
1723 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1724 1, 2, 0,
1725 doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1726 BUFFER defaults to the current buffer. */)
1727 (variable, buffer)
1728 register Lisp_Object variable, buffer;
1730 Lisp_Object valcontents;
1731 register struct buffer *buf;
1733 if (NILP (buffer))
1734 buf = current_buffer;
1735 else
1737 CHECK_BUFFER (buffer);
1738 buf = XBUFFER (buffer);
1741 CHECK_SYMBOL (variable);
1742 variable = indirect_variable (variable);
1744 valcontents = SYMBOL_VALUE (variable);
1745 if (BUFFER_LOCAL_VALUEP (valcontents))
1747 Lisp_Object tail, elt;
1749 for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
1751 elt = XCAR (tail);
1752 if (EQ (variable, XCAR (elt)))
1753 return Qt;
1756 if (BUFFER_OBJFWDP (valcontents))
1758 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1759 int idx = PER_BUFFER_IDX (offset);
1760 if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
1761 return Qt;
1763 return Qnil;
1766 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1767 1, 2, 0,
1768 doc: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1769 More precisely, this means that setting the variable \(with `set' or`setq'),
1770 while it does not have a `let'-style binding that was made in BUFFER,
1771 will produce a buffer local binding. See Info node
1772 `(elisp)Creating Buffer-Local'.
1773 BUFFER defaults to the current buffer. */)
1774 (variable, buffer)
1775 register Lisp_Object variable, buffer;
1777 Lisp_Object valcontents;
1778 register struct buffer *buf;
1780 if (NILP (buffer))
1781 buf = current_buffer;
1782 else
1784 CHECK_BUFFER (buffer);
1785 buf = XBUFFER (buffer);
1788 CHECK_SYMBOL (variable);
1789 variable = indirect_variable (variable);
1791 valcontents = SYMBOL_VALUE (variable);
1793 if (BUFFER_OBJFWDP (valcontents))
1794 /* All these slots become local if they are set. */
1795 return Qt;
1796 else if (BUFFER_LOCAL_VALUEP (valcontents))
1798 Lisp_Object tail, elt;
1799 if (XBUFFER_LOCAL_VALUE (valcontents)->local_if_set)
1800 return Qt;
1801 for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
1803 elt = XCAR (tail);
1804 if (EQ (variable, XCAR (elt)))
1805 return Qt;
1808 return Qnil;
1811 DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
1812 1, 1, 0,
1813 doc: /* Return a value indicating where VARIABLE's current binding comes from.
1814 If the current binding is buffer-local, the value is the current buffer.
1815 If the current binding is frame-local, the value is the selected frame.
1816 If the current binding is global (the default), the value is nil. */)
1817 (variable)
1818 register Lisp_Object variable;
1820 Lisp_Object valcontents;
1822 CHECK_SYMBOL (variable);
1823 variable = indirect_variable (variable);
1825 /* Make sure the current binding is actually swapped in. */
1826 find_symbol_value (variable);
1828 valcontents = XSYMBOL (variable)->value;
1830 if (BUFFER_LOCAL_VALUEP (valcontents)
1831 || BUFFER_OBJFWDP (valcontents))
1833 /* For a local variable, record both the symbol and which
1834 buffer's or frame's value we are saving. */
1835 if (!NILP (Flocal_variable_p (variable, Qnil)))
1836 return Fcurrent_buffer ();
1837 else if (BUFFER_LOCAL_VALUEP (valcontents)
1838 && XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame)
1839 return XBUFFER_LOCAL_VALUE (valcontents)->frame;
1842 return Qnil;
1845 /* This code is disabled now that we use the selected frame to return
1846 keyboard-local-values. */
1847 #if 0
1848 extern struct terminal *get_terminal P_ ((Lisp_Object display, int));
1850 DEFUN ("terminal-local-value", Fterminal_local_value, Sterminal_local_value, 2, 2, 0,
1851 doc: /* Return the terminal-local value of SYMBOL on TERMINAL.
1852 If SYMBOL is not a terminal-local variable, then return its normal
1853 value, like `symbol-value'.
1855 TERMINAL may be a terminal id, a frame, or nil (meaning the
1856 selected frame's terminal device). */)
1857 (symbol, terminal)
1858 Lisp_Object symbol;
1859 Lisp_Object terminal;
1861 Lisp_Object result;
1862 struct terminal *t = get_terminal (terminal, 1);
1863 push_kboard (t->kboard);
1864 result = Fsymbol_value (symbol);
1865 pop_kboard ();
1866 return result;
1869 DEFUN ("set-terminal-local-value", Fset_terminal_local_value, Sset_terminal_local_value, 3, 3, 0,
1870 doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1871 If VARIABLE is not a terminal-local variable, then set its normal
1872 binding, like `set'.
1874 TERMINAL may be a terminal id, a frame, or nil (meaning the
1875 selected frame's terminal device). */)
1876 (symbol, terminal, value)
1877 Lisp_Object symbol;
1878 Lisp_Object terminal;
1879 Lisp_Object value;
1881 Lisp_Object result;
1882 struct terminal *t = get_terminal (terminal, 1);
1883 push_kboard (d->kboard);
1884 result = Fset (symbol, value);
1885 pop_kboard ();
1886 return result;
1888 #endif
1890 /* Find the function at the end of a chain of symbol function indirections. */
1892 /* If OBJECT is a symbol, find the end of its function chain and
1893 return the value found there. If OBJECT is not a symbol, just
1894 return it. If there is a cycle in the function chain, signal a
1895 cyclic-function-indirection error.
1897 This is like Findirect_function, except that it doesn't signal an
1898 error if the chain ends up unbound. */
1899 Lisp_Object
1900 indirect_function (object)
1901 register Lisp_Object object;
1903 Lisp_Object tortoise, hare;
1905 hare = tortoise = object;
1907 for (;;)
1909 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1910 break;
1911 hare = XSYMBOL (hare)->function;
1912 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1913 break;
1914 hare = XSYMBOL (hare)->function;
1916 tortoise = XSYMBOL (tortoise)->function;
1918 if (EQ (hare, tortoise))
1919 xsignal1 (Qcyclic_function_indirection, object);
1922 return hare;
1925 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
1926 doc: /* Return the function at the end of OBJECT's function chain.
1927 If OBJECT is not a symbol, just return it. Otherwise, follow all
1928 function indirections to find the final function binding and return it.
1929 If the final symbol in the chain is unbound, signal a void-function error.
1930 Optional arg NOERROR non-nil means to return nil instead of signalling.
1931 Signal a cyclic-function-indirection error if there is a loop in the
1932 function chain of symbols. */)
1933 (object, noerror)
1934 register Lisp_Object object;
1935 Lisp_Object noerror;
1937 Lisp_Object result;
1939 /* Optimize for no indirection. */
1940 result = object;
1941 if (SYMBOLP (result) && !EQ (result, Qunbound)
1942 && (result = XSYMBOL (result)->function, SYMBOLP (result)))
1943 result = indirect_function (result);
1944 if (!EQ (result, Qunbound))
1945 return result;
1947 if (NILP (noerror))
1948 xsignal1 (Qvoid_function, object);
1950 return Qnil;
1953 /* Extract and set vector and string elements */
1955 DEFUN ("aref", Faref, Saref, 2, 2, 0,
1956 doc: /* Return the element of ARRAY at index IDX.
1957 ARRAY may be a vector, a string, a char-table, a bool-vector,
1958 or a byte-code object. IDX starts at 0. */)
1959 (array, idx)
1960 register Lisp_Object array;
1961 Lisp_Object idx;
1963 register int idxval;
1965 CHECK_NUMBER (idx);
1966 idxval = XINT (idx);
1967 if (STRINGP (array))
1969 int c, idxval_byte;
1971 if (idxval < 0 || idxval >= SCHARS (array))
1972 args_out_of_range (array, idx);
1973 if (! STRING_MULTIBYTE (array))
1974 return make_number ((unsigned char) SREF (array, idxval));
1975 idxval_byte = string_char_to_byte (array, idxval);
1977 c = STRING_CHAR (SDATA (array) + idxval_byte,
1978 SBYTES (array) - idxval_byte);
1979 return make_number (c);
1981 else if (BOOL_VECTOR_P (array))
1983 int val;
1985 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1986 args_out_of_range (array, idx);
1988 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
1989 return (val & (1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR)) ? Qt : Qnil);
1991 else if (CHAR_TABLE_P (array))
1993 CHECK_CHARACTER (idx);
1994 return CHAR_TABLE_REF (array, idxval);
1996 else
1998 int size = 0;
1999 if (VECTORP (array))
2000 size = XVECTOR (array)->size;
2001 else if (COMPILEDP (array))
2002 size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
2003 else
2004 wrong_type_argument (Qarrayp, array);
2006 if (idxval < 0 || idxval >= size)
2007 args_out_of_range (array, idx);
2008 return XVECTOR (array)->contents[idxval];
2012 DEFUN ("aset", Faset, Saset, 3, 3, 0,
2013 doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
2014 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2015 bool-vector. IDX starts at 0. */)
2016 (array, idx, newelt)
2017 register Lisp_Object array;
2018 Lisp_Object idx, newelt;
2020 register int idxval;
2022 CHECK_NUMBER (idx);
2023 idxval = XINT (idx);
2024 CHECK_ARRAY (array, Qarrayp);
2025 CHECK_IMPURE (array);
2027 if (VECTORP (array))
2029 if (idxval < 0 || idxval >= XVECTOR (array)->size)
2030 args_out_of_range (array, idx);
2031 XVECTOR (array)->contents[idxval] = newelt;
2033 else if (BOOL_VECTOR_P (array))
2035 int val;
2037 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
2038 args_out_of_range (array, idx);
2040 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR];
2042 if (! NILP (newelt))
2043 val |= 1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR);
2044 else
2045 val &= ~(1 << (idxval % BOOL_VECTOR_BITS_PER_CHAR));
2046 XBOOL_VECTOR (array)->data[idxval / BOOL_VECTOR_BITS_PER_CHAR] = val;
2048 else if (CHAR_TABLE_P (array))
2050 CHECK_CHARACTER (idx);
2051 CHAR_TABLE_SET (array, idxval, newelt);
2053 else if (STRING_MULTIBYTE (array))
2055 int idxval_byte, prev_bytes, new_bytes, nbytes;
2056 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
2058 if (idxval < 0 || idxval >= SCHARS (array))
2059 args_out_of_range (array, idx);
2060 CHECK_CHARACTER (newelt);
2062 nbytes = SBYTES (array);
2064 idxval_byte = string_char_to_byte (array, idxval);
2065 p1 = SDATA (array) + idxval_byte;
2066 PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes);
2067 new_bytes = CHAR_STRING (XINT (newelt), p0);
2068 if (prev_bytes != new_bytes)
2070 /* We must relocate the string data. */
2071 int nchars = SCHARS (array);
2072 unsigned char *str;
2073 USE_SAFE_ALLOCA;
2075 SAFE_ALLOCA (str, unsigned char *, nbytes);
2076 bcopy (SDATA (array), str, nbytes);
2077 allocate_string_data (XSTRING (array), nchars,
2078 nbytes + new_bytes - prev_bytes);
2079 bcopy (str, SDATA (array), idxval_byte);
2080 p1 = SDATA (array) + idxval_byte;
2081 bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
2082 nbytes - (idxval_byte + prev_bytes));
2083 SAFE_FREE ();
2084 clear_string_char_byte_cache ();
2086 while (new_bytes--)
2087 *p1++ = *p0++;
2089 else
2091 if (idxval < 0 || idxval >= SCHARS (array))
2092 args_out_of_range (array, idx);
2093 CHECK_NUMBER (newelt);
2095 if (XINT (newelt) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt)))
2096 args_out_of_range (array, newelt);
2097 SSET (array, idxval, XINT (newelt));
2100 return newelt;
2103 /* Arithmetic functions */
2105 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
2107 Lisp_Object
2108 arithcompare (num1, num2, comparison)
2109 Lisp_Object num1, num2;
2110 enum comparison comparison;
2112 double f1 = 0, f2 = 0;
2113 int floatp = 0;
2115 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
2116 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
2118 if (FLOATP (num1) || FLOATP (num2))
2120 floatp = 1;
2121 f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
2122 f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
2125 switch (comparison)
2127 case equal:
2128 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
2129 return Qt;
2130 return Qnil;
2132 case notequal:
2133 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
2134 return Qt;
2135 return Qnil;
2137 case less:
2138 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
2139 return Qt;
2140 return Qnil;
2142 case less_or_equal:
2143 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
2144 return Qt;
2145 return Qnil;
2147 case grtr:
2148 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
2149 return Qt;
2150 return Qnil;
2152 case grtr_or_equal:
2153 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
2154 return Qt;
2155 return Qnil;
2157 default:
2158 abort ();
2162 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
2163 doc: /* Return t if two args, both numbers or markers, are equal. */)
2164 (num1, num2)
2165 register Lisp_Object num1, num2;
2167 return arithcompare (num1, num2, equal);
2170 DEFUN ("<", Flss, Slss, 2, 2, 0,
2171 doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2172 (num1, num2)
2173 register Lisp_Object num1, num2;
2175 return arithcompare (num1, num2, less);
2178 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
2179 doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2180 (num1, num2)
2181 register Lisp_Object num1, num2;
2183 return arithcompare (num1, num2, grtr);
2186 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
2187 doc: /* Return t if first arg is less than or equal to second arg.
2188 Both must be numbers or markers. */)
2189 (num1, num2)
2190 register Lisp_Object num1, num2;
2192 return arithcompare (num1, num2, less_or_equal);
2195 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
2196 doc: /* Return t if first arg is greater than or equal to second arg.
2197 Both must be numbers or markers. */)
2198 (num1, num2)
2199 register Lisp_Object num1, num2;
2201 return arithcompare (num1, num2, grtr_or_equal);
2204 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
2205 doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2206 (num1, num2)
2207 register Lisp_Object num1, num2;
2209 return arithcompare (num1, num2, notequal);
2212 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
2213 doc: /* Return t if NUMBER is zero. */)
2214 (number)
2215 register Lisp_Object number;
2217 CHECK_NUMBER_OR_FLOAT (number);
2219 if (FLOATP (number))
2221 if (XFLOAT_DATA (number) == 0.0)
2222 return Qt;
2223 return Qnil;
2226 if (!XINT (number))
2227 return Qt;
2228 return Qnil;
2231 /* Convert between long values and pairs of Lisp integers.
2232 Note that long_to_cons returns a single Lisp integer
2233 when the value fits in one. */
2235 Lisp_Object
2236 long_to_cons (i)
2237 unsigned long i;
2239 unsigned long top = i >> 16;
2240 unsigned int bot = i & 0xFFFF;
2241 if (top == 0)
2242 return make_number (bot);
2243 if (top == (unsigned long)-1 >> 16)
2244 return Fcons (make_number (-1), make_number (bot));
2245 return Fcons (make_number (top), make_number (bot));
2248 unsigned long
2249 cons_to_long (c)
2250 Lisp_Object c;
2252 Lisp_Object top, bot;
2253 if (INTEGERP (c))
2254 return XINT (c);
2255 top = XCAR (c);
2256 bot = XCDR (c);
2257 if (CONSP (bot))
2258 bot = XCAR (bot);
2259 return ((XINT (top) << 16) | XINT (bot));
2262 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
2263 doc: /* Return the decimal representation of NUMBER as a string.
2264 Uses a minus sign if negative.
2265 NUMBER may be an integer or a floating point number. */)
2266 (number)
2267 Lisp_Object number;
2269 char buffer[VALBITS];
2271 CHECK_NUMBER_OR_FLOAT (number);
2273 if (FLOATP (number))
2275 char pigbuf[350]; /* see comments in float_to_string */
2277 float_to_string (pigbuf, XFLOAT_DATA (number));
2278 return build_string (pigbuf);
2281 if (sizeof (int) == sizeof (EMACS_INT))
2282 sprintf (buffer, "%d", (int) XINT (number));
2283 else if (sizeof (long) == sizeof (EMACS_INT))
2284 sprintf (buffer, "%ld", (long) XINT (number));
2285 else
2286 abort ();
2287 return build_string (buffer);
2290 INLINE static int
2291 digit_to_number (character, base)
2292 int character, base;
2294 int digit;
2296 if (character >= '0' && character <= '9')
2297 digit = character - '0';
2298 else if (character >= 'a' && character <= 'z')
2299 digit = character - 'a' + 10;
2300 else if (character >= 'A' && character <= 'Z')
2301 digit = character - 'A' + 10;
2302 else
2303 return -1;
2305 if (digit >= base)
2306 return -1;
2307 else
2308 return digit;
2311 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
2312 doc: /* Parse STRING as a decimal number and return the number.
2313 This parses both integers and floating point numbers.
2314 It ignores leading spaces and tabs.
2316 If BASE, interpret STRING as a number in that base. If BASE isn't
2317 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2318 If the base used is not 10, floating point is not recognized. */)
2319 (string, base)
2320 register Lisp_Object string, base;
2322 register unsigned char *p;
2323 register int b;
2324 int sign = 1;
2325 Lisp_Object val;
2327 CHECK_STRING (string);
2329 if (NILP (base))
2330 b = 10;
2331 else
2333 CHECK_NUMBER (base);
2334 b = XINT (base);
2335 if (b < 2 || b > 16)
2336 xsignal1 (Qargs_out_of_range, base);
2339 /* Skip any whitespace at the front of the number. Some versions of
2340 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2341 p = SDATA (string);
2342 while (*p == ' ' || *p == '\t')
2343 p++;
2345 if (*p == '-')
2347 sign = -1;
2348 p++;
2350 else if (*p == '+')
2351 p++;
2353 if (isfloat_string (p) && b == 10)
2354 val = make_float (sign * atof (p));
2355 else
2357 double v = 0;
2359 while (1)
2361 int digit = digit_to_number (*p++, b);
2362 if (digit < 0)
2363 break;
2364 v = v * b + digit;
2367 val = make_fixnum_or_float (sign * v);
2370 return val;
2374 enum arithop
2376 Aadd,
2377 Asub,
2378 Amult,
2379 Adiv,
2380 Alogand,
2381 Alogior,
2382 Alogxor,
2383 Amax,
2384 Amin
2387 static Lisp_Object float_arith_driver P_ ((double, int, enum arithop,
2388 int, Lisp_Object *));
2389 extern Lisp_Object fmod_float ();
2391 Lisp_Object
2392 arith_driver (code, nargs, args)
2393 enum arithop code;
2394 int nargs;
2395 register Lisp_Object *args;
2397 register Lisp_Object val;
2398 register int argnum;
2399 register EMACS_INT accum = 0;
2400 register EMACS_INT next;
2402 switch (SWITCH_ENUM_CAST (code))
2404 case Alogior:
2405 case Alogxor:
2406 case Aadd:
2407 case Asub:
2408 accum = 0;
2409 break;
2410 case Amult:
2411 accum = 1;
2412 break;
2413 case Alogand:
2414 accum = -1;
2415 break;
2416 default:
2417 break;
2420 for (argnum = 0; argnum < nargs; argnum++)
2422 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2423 val = args[argnum];
2424 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2426 if (FLOATP (val))
2427 return float_arith_driver ((double) accum, argnum, code,
2428 nargs, args);
2429 args[argnum] = val;
2430 next = XINT (args[argnum]);
2431 switch (SWITCH_ENUM_CAST (code))
2433 case Aadd:
2434 accum += next;
2435 break;
2436 case Asub:
2437 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2438 break;
2439 case Amult:
2440 accum *= next;
2441 break;
2442 case Adiv:
2443 if (!argnum)
2444 accum = next;
2445 else
2447 if (next == 0)
2448 xsignal0 (Qarith_error);
2449 accum /= next;
2451 break;
2452 case Alogand:
2453 accum &= next;
2454 break;
2455 case Alogior:
2456 accum |= next;
2457 break;
2458 case Alogxor:
2459 accum ^= next;
2460 break;
2461 case Amax:
2462 if (!argnum || next > accum)
2463 accum = next;
2464 break;
2465 case Amin:
2466 if (!argnum || next < accum)
2467 accum = next;
2468 break;
2472 XSETINT (val, accum);
2473 return val;
2476 #undef isnan
2477 #define isnan(x) ((x) != (x))
2479 static Lisp_Object
2480 float_arith_driver (accum, argnum, code, nargs, args)
2481 double accum;
2482 register int argnum;
2483 enum arithop code;
2484 int nargs;
2485 register Lisp_Object *args;
2487 register Lisp_Object val;
2488 double next;
2490 for (; argnum < nargs; argnum++)
2492 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2493 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2495 if (FLOATP (val))
2497 next = XFLOAT_DATA (val);
2499 else
2501 args[argnum] = val; /* runs into a compiler bug. */
2502 next = XINT (args[argnum]);
2504 switch (SWITCH_ENUM_CAST (code))
2506 case Aadd:
2507 accum += next;
2508 break;
2509 case Asub:
2510 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2511 break;
2512 case Amult:
2513 accum *= next;
2514 break;
2515 case Adiv:
2516 if (!argnum)
2517 accum = next;
2518 else
2520 if (! IEEE_FLOATING_POINT && next == 0)
2521 xsignal0 (Qarith_error);
2522 accum /= next;
2524 break;
2525 case Alogand:
2526 case Alogior:
2527 case Alogxor:
2528 return wrong_type_argument (Qinteger_or_marker_p, val);
2529 case Amax:
2530 if (!argnum || isnan (next) || next > accum)
2531 accum = next;
2532 break;
2533 case Amin:
2534 if (!argnum || isnan (next) || next < accum)
2535 accum = next;
2536 break;
2540 return make_float (accum);
2544 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2545 doc: /* Return sum of any number of arguments, which are numbers or markers.
2546 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2547 (nargs, args)
2548 int nargs;
2549 Lisp_Object *args;
2551 return arith_driver (Aadd, nargs, args);
2554 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2555 doc: /* Negate number or subtract numbers or markers and return the result.
2556 With one arg, negates it. With more than one arg,
2557 subtracts all but the first from the first.
2558 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2559 (nargs, args)
2560 int nargs;
2561 Lisp_Object *args;
2563 return arith_driver (Asub, nargs, args);
2566 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2567 doc: /* Return product of any number of arguments, which are numbers or markers.
2568 usage: (* &rest NUMBERS-OR-MARKERS) */)
2569 (nargs, args)
2570 int nargs;
2571 Lisp_Object *args;
2573 return arith_driver (Amult, nargs, args);
2576 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
2577 doc: /* Return first argument divided by all the remaining arguments.
2578 The arguments must be numbers or markers.
2579 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2580 (nargs, args)
2581 int nargs;
2582 Lisp_Object *args;
2584 int argnum;
2585 for (argnum = 2; argnum < nargs; argnum++)
2586 if (FLOATP (args[argnum]))
2587 return float_arith_driver (0, 0, Adiv, nargs, args);
2588 return arith_driver (Adiv, nargs, args);
2591 DEFUN ("%", Frem, Srem, 2, 2, 0,
2592 doc: /* Return remainder of X divided by Y.
2593 Both must be integers or markers. */)
2594 (x, y)
2595 register Lisp_Object x, y;
2597 Lisp_Object val;
2599 CHECK_NUMBER_COERCE_MARKER (x);
2600 CHECK_NUMBER_COERCE_MARKER (y);
2602 if (XFASTINT (y) == 0)
2603 xsignal0 (Qarith_error);
2605 XSETINT (val, XINT (x) % XINT (y));
2606 return val;
2609 #ifndef HAVE_FMOD
2610 double
2611 fmod (f1, f2)
2612 double f1, f2;
2614 double r = f1;
2616 if (f2 < 0.0)
2617 f2 = -f2;
2619 /* If the magnitude of the result exceeds that of the divisor, or
2620 the sign of the result does not agree with that of the dividend,
2621 iterate with the reduced value. This does not yield a
2622 particularly accurate result, but at least it will be in the
2623 range promised by fmod. */
2625 r -= f2 * floor (r / f2);
2626 while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
2628 return r;
2630 #endif /* ! HAVE_FMOD */
2632 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2633 doc: /* Return X modulo Y.
2634 The result falls between zero (inclusive) and Y (exclusive).
2635 Both X and Y must be numbers or markers. */)
2636 (x, y)
2637 register Lisp_Object x, y;
2639 Lisp_Object val;
2640 EMACS_INT i1, i2;
2642 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
2643 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
2645 if (FLOATP (x) || FLOATP (y))
2646 return fmod_float (x, y);
2648 i1 = XINT (x);
2649 i2 = XINT (y);
2651 if (i2 == 0)
2652 xsignal0 (Qarith_error);
2654 i1 %= i2;
2656 /* If the "remainder" comes out with the wrong sign, fix it. */
2657 if (i2 < 0 ? i1 > 0 : i1 < 0)
2658 i1 += i2;
2660 XSETINT (val, i1);
2661 return val;
2664 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2665 doc: /* Return largest of all the arguments (which must be numbers or markers).
2666 The value is always a number; markers are converted to numbers.
2667 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2668 (nargs, args)
2669 int nargs;
2670 Lisp_Object *args;
2672 return arith_driver (Amax, nargs, args);
2675 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2676 doc: /* Return smallest of all the arguments (which must be numbers or markers).
2677 The value is always a number; markers are converted to numbers.
2678 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2679 (nargs, args)
2680 int nargs;
2681 Lisp_Object *args;
2683 return arith_driver (Amin, nargs, args);
2686 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2687 doc: /* Return bitwise-and of all the arguments.
2688 Arguments may be integers, or markers converted to integers.
2689 usage: (logand &rest INTS-OR-MARKERS) */)
2690 (nargs, args)
2691 int nargs;
2692 Lisp_Object *args;
2694 return arith_driver (Alogand, nargs, args);
2697 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2698 doc: /* Return bitwise-or of all the arguments.
2699 Arguments may be integers, or markers converted to integers.
2700 usage: (logior &rest INTS-OR-MARKERS) */)
2701 (nargs, args)
2702 int nargs;
2703 Lisp_Object *args;
2705 return arith_driver (Alogior, nargs, args);
2708 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2709 doc: /* Return bitwise-exclusive-or of all the arguments.
2710 Arguments may be integers, or markers converted to integers.
2711 usage: (logxor &rest INTS-OR-MARKERS) */)
2712 (nargs, args)
2713 int nargs;
2714 Lisp_Object *args;
2716 return arith_driver (Alogxor, nargs, args);
2719 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2720 doc: /* Return VALUE with its bits shifted left by COUNT.
2721 If COUNT is negative, shifting is actually to the right.
2722 In this case, the sign bit is duplicated. */)
2723 (value, count)
2724 register Lisp_Object value, count;
2726 register Lisp_Object val;
2728 CHECK_NUMBER (value);
2729 CHECK_NUMBER (count);
2731 if (XINT (count) >= BITS_PER_EMACS_INT)
2732 XSETINT (val, 0);
2733 else if (XINT (count) > 0)
2734 XSETINT (val, XINT (value) << XFASTINT (count));
2735 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2736 XSETINT (val, XINT (value) < 0 ? -1 : 0);
2737 else
2738 XSETINT (val, XINT (value) >> -XINT (count));
2739 return val;
2742 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2743 doc: /* Return VALUE with its bits shifted left by COUNT.
2744 If COUNT is negative, shifting is actually to the right.
2745 In this case, zeros are shifted in on the left. */)
2746 (value, count)
2747 register Lisp_Object value, count;
2749 register Lisp_Object val;
2751 CHECK_NUMBER (value);
2752 CHECK_NUMBER (count);
2754 if (XINT (count) >= BITS_PER_EMACS_INT)
2755 XSETINT (val, 0);
2756 else if (XINT (count) > 0)
2757 XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
2758 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2759 XSETINT (val, 0);
2760 else
2761 XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
2762 return val;
2765 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2766 doc: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2767 Markers are converted to integers. */)
2768 (number)
2769 register Lisp_Object number;
2771 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2773 if (FLOATP (number))
2774 return (make_float (1.0 + XFLOAT_DATA (number)));
2776 XSETINT (number, XINT (number) + 1);
2777 return number;
2780 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
2781 doc: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2782 Markers are converted to integers. */)
2783 (number)
2784 register Lisp_Object number;
2786 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2788 if (FLOATP (number))
2789 return (make_float (-1.0 + XFLOAT_DATA (number)));
2791 XSETINT (number, XINT (number) - 1);
2792 return number;
2795 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2796 doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2797 (number)
2798 register Lisp_Object number;
2800 CHECK_NUMBER (number);
2801 XSETINT (number, ~XINT (number));
2802 return number;
2805 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
2806 doc: /* Return the byteorder for the machine.
2807 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2808 lowercase l) for small endian machines. */)
2811 unsigned i = 0x04030201;
2812 int order = *(char *)&i == 1 ? 108 : 66;
2814 return make_number (order);
2819 void
2820 syms_of_data ()
2822 Lisp_Object error_tail, arith_tail;
2824 Qquote = intern ("quote");
2825 Qlambda = intern ("lambda");
2826 Qsubr = intern ("subr");
2827 Qerror_conditions = intern ("error-conditions");
2828 Qerror_message = intern ("error-message");
2829 Qtop_level = intern ("top-level");
2831 Qerror = intern ("error");
2832 Qquit = intern ("quit");
2833 Qwrong_type_argument = intern ("wrong-type-argument");
2834 Qargs_out_of_range = intern ("args-out-of-range");
2835 Qvoid_function = intern ("void-function");
2836 Qcyclic_function_indirection = intern ("cyclic-function-indirection");
2837 Qcyclic_variable_indirection = intern ("cyclic-variable-indirection");
2838 Qvoid_variable = intern ("void-variable");
2839 Qsetting_constant = intern ("setting-constant");
2840 Qinvalid_read_syntax = intern ("invalid-read-syntax");
2842 Qinvalid_function = intern ("invalid-function");
2843 Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
2844 Qno_catch = intern ("no-catch");
2845 Qend_of_file = intern ("end-of-file");
2846 Qarith_error = intern ("arith-error");
2847 Qbeginning_of_buffer = intern ("beginning-of-buffer");
2848 Qend_of_buffer = intern ("end-of-buffer");
2849 Qbuffer_read_only = intern ("buffer-read-only");
2850 Qtext_read_only = intern ("text-read-only");
2851 Qmark_inactive = intern ("mark-inactive");
2853 Qlistp = intern ("listp");
2854 Qconsp = intern ("consp");
2855 Qsymbolp = intern ("symbolp");
2856 Qkeywordp = intern ("keywordp");
2857 Qintegerp = intern ("integerp");
2858 Qnatnump = intern ("natnump");
2859 Qwholenump = intern ("wholenump");
2860 Qstringp = intern ("stringp");
2861 Qarrayp = intern ("arrayp");
2862 Qsequencep = intern ("sequencep");
2863 Qbufferp = intern ("bufferp");
2864 Qvectorp = intern ("vectorp");
2865 Qchar_or_string_p = intern ("char-or-string-p");
2866 Qmarkerp = intern ("markerp");
2867 Qbuffer_or_string_p = intern ("buffer-or-string-p");
2868 Qinteger_or_marker_p = intern ("integer-or-marker-p");
2869 Qboundp = intern ("boundp");
2870 Qfboundp = intern ("fboundp");
2872 Qfloatp = intern ("floatp");
2873 Qnumberp = intern ("numberp");
2874 Qnumber_or_marker_p = intern ("number-or-marker-p");
2876 Qchar_table_p = intern ("char-table-p");
2877 Qvector_or_char_table_p = intern ("vector-or-char-table-p");
2879 Qsubrp = intern ("subrp");
2880 Qunevalled = intern ("unevalled");
2881 Qmany = intern ("many");
2883 Qcdr = intern ("cdr");
2885 /* Handle automatic advice activation */
2886 Qad_advice_info = intern ("ad-advice-info");
2887 Qad_activate_internal = intern ("ad-activate-internal");
2889 error_tail = Fcons (Qerror, Qnil);
2891 /* ERROR is used as a signaler for random errors for which nothing else is right */
2893 Fput (Qerror, Qerror_conditions,
2894 error_tail);
2895 Fput (Qerror, Qerror_message,
2896 build_string ("error"));
2898 Fput (Qquit, Qerror_conditions,
2899 Fcons (Qquit, Qnil));
2900 Fput (Qquit, Qerror_message,
2901 build_string ("Quit"));
2903 Fput (Qwrong_type_argument, Qerror_conditions,
2904 Fcons (Qwrong_type_argument, error_tail));
2905 Fput (Qwrong_type_argument, Qerror_message,
2906 build_string ("Wrong type argument"));
2908 Fput (Qargs_out_of_range, Qerror_conditions,
2909 Fcons (Qargs_out_of_range, error_tail));
2910 Fput (Qargs_out_of_range, Qerror_message,
2911 build_string ("Args out of range"));
2913 Fput (Qvoid_function, Qerror_conditions,
2914 Fcons (Qvoid_function, error_tail));
2915 Fput (Qvoid_function, Qerror_message,
2916 build_string ("Symbol's function definition is void"));
2918 Fput (Qcyclic_function_indirection, Qerror_conditions,
2919 Fcons (Qcyclic_function_indirection, error_tail));
2920 Fput (Qcyclic_function_indirection, Qerror_message,
2921 build_string ("Symbol's chain of function indirections contains a loop"));
2923 Fput (Qcyclic_variable_indirection, Qerror_conditions,
2924 Fcons (Qcyclic_variable_indirection, error_tail));
2925 Fput (Qcyclic_variable_indirection, Qerror_message,
2926 build_string ("Symbol's chain of variable indirections contains a loop"));
2928 Qcircular_list = intern ("circular-list");
2929 staticpro (&Qcircular_list);
2930 Fput (Qcircular_list, Qerror_conditions,
2931 Fcons (Qcircular_list, error_tail));
2932 Fput (Qcircular_list, Qerror_message,
2933 build_string ("List contains a loop"));
2935 Fput (Qvoid_variable, Qerror_conditions,
2936 Fcons (Qvoid_variable, error_tail));
2937 Fput (Qvoid_variable, Qerror_message,
2938 build_string ("Symbol's value as variable is void"));
2940 Fput (Qsetting_constant, Qerror_conditions,
2941 Fcons (Qsetting_constant, error_tail));
2942 Fput (Qsetting_constant, Qerror_message,
2943 build_string ("Attempt to set a constant symbol"));
2945 Fput (Qinvalid_read_syntax, Qerror_conditions,
2946 Fcons (Qinvalid_read_syntax, error_tail));
2947 Fput (Qinvalid_read_syntax, Qerror_message,
2948 build_string ("Invalid read syntax"));
2950 Fput (Qinvalid_function, Qerror_conditions,
2951 Fcons (Qinvalid_function, error_tail));
2952 Fput (Qinvalid_function, Qerror_message,
2953 build_string ("Invalid function"));
2955 Fput (Qwrong_number_of_arguments, Qerror_conditions,
2956 Fcons (Qwrong_number_of_arguments, error_tail));
2957 Fput (Qwrong_number_of_arguments, Qerror_message,
2958 build_string ("Wrong number of arguments"));
2960 Fput (Qno_catch, Qerror_conditions,
2961 Fcons (Qno_catch, error_tail));
2962 Fput (Qno_catch, Qerror_message,
2963 build_string ("No catch for tag"));
2965 Fput (Qend_of_file, Qerror_conditions,
2966 Fcons (Qend_of_file, error_tail));
2967 Fput (Qend_of_file, Qerror_message,
2968 build_string ("End of file during parsing"));
2970 arith_tail = Fcons (Qarith_error, error_tail);
2971 Fput (Qarith_error, Qerror_conditions,
2972 arith_tail);
2973 Fput (Qarith_error, Qerror_message,
2974 build_string ("Arithmetic error"));
2976 Fput (Qbeginning_of_buffer, Qerror_conditions,
2977 Fcons (Qbeginning_of_buffer, error_tail));
2978 Fput (Qbeginning_of_buffer, Qerror_message,
2979 build_string ("Beginning of buffer"));
2981 Fput (Qend_of_buffer, Qerror_conditions,
2982 Fcons (Qend_of_buffer, error_tail));
2983 Fput (Qend_of_buffer, Qerror_message,
2984 build_string ("End of buffer"));
2986 Fput (Qbuffer_read_only, Qerror_conditions,
2987 Fcons (Qbuffer_read_only, error_tail));
2988 Fput (Qbuffer_read_only, Qerror_message,
2989 build_string ("Buffer is read-only"));
2991 Fput (Qtext_read_only, Qerror_conditions,
2992 Fcons (Qtext_read_only, error_tail));
2993 Fput (Qtext_read_only, Qerror_message,
2994 build_string ("Text is read-only"));
2996 Qrange_error = intern ("range-error");
2997 Qdomain_error = intern ("domain-error");
2998 Qsingularity_error = intern ("singularity-error");
2999 Qoverflow_error = intern ("overflow-error");
3000 Qunderflow_error = intern ("underflow-error");
3002 Fput (Qdomain_error, Qerror_conditions,
3003 Fcons (Qdomain_error, arith_tail));
3004 Fput (Qdomain_error, Qerror_message,
3005 build_string ("Arithmetic domain error"));
3007 Fput (Qrange_error, Qerror_conditions,
3008 Fcons (Qrange_error, arith_tail));
3009 Fput (Qrange_error, Qerror_message,
3010 build_string ("Arithmetic range error"));
3012 Fput (Qsingularity_error, Qerror_conditions,
3013 Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
3014 Fput (Qsingularity_error, Qerror_message,
3015 build_string ("Arithmetic singularity error"));
3017 Fput (Qoverflow_error, Qerror_conditions,
3018 Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
3019 Fput (Qoverflow_error, Qerror_message,
3020 build_string ("Arithmetic overflow error"));
3022 Fput (Qunderflow_error, Qerror_conditions,
3023 Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
3024 Fput (Qunderflow_error, Qerror_message,
3025 build_string ("Arithmetic underflow error"));
3027 staticpro (&Qrange_error);
3028 staticpro (&Qdomain_error);
3029 staticpro (&Qsingularity_error);
3030 staticpro (&Qoverflow_error);
3031 staticpro (&Qunderflow_error);
3033 staticpro (&Qnil);
3034 staticpro (&Qt);
3035 staticpro (&Qquote);
3036 staticpro (&Qlambda);
3037 staticpro (&Qsubr);
3038 staticpro (&Qunbound);
3039 staticpro (&Qerror_conditions);
3040 staticpro (&Qerror_message);
3041 staticpro (&Qtop_level);
3043 staticpro (&Qerror);
3044 staticpro (&Qquit);
3045 staticpro (&Qwrong_type_argument);
3046 staticpro (&Qargs_out_of_range);
3047 staticpro (&Qvoid_function);
3048 staticpro (&Qcyclic_function_indirection);
3049 staticpro (&Qcyclic_variable_indirection);
3050 staticpro (&Qvoid_variable);
3051 staticpro (&Qsetting_constant);
3052 staticpro (&Qinvalid_read_syntax);
3053 staticpro (&Qwrong_number_of_arguments);
3054 staticpro (&Qinvalid_function);
3055 staticpro (&Qno_catch);
3056 staticpro (&Qend_of_file);
3057 staticpro (&Qarith_error);
3058 staticpro (&Qbeginning_of_buffer);
3059 staticpro (&Qend_of_buffer);
3060 staticpro (&Qbuffer_read_only);
3061 staticpro (&Qtext_read_only);
3062 staticpro (&Qmark_inactive);
3064 staticpro (&Qlistp);
3065 staticpro (&Qconsp);
3066 staticpro (&Qsymbolp);
3067 staticpro (&Qkeywordp);
3068 staticpro (&Qintegerp);
3069 staticpro (&Qnatnump);
3070 staticpro (&Qwholenump);
3071 staticpro (&Qstringp);
3072 staticpro (&Qarrayp);
3073 staticpro (&Qsequencep);
3074 staticpro (&Qbufferp);
3075 staticpro (&Qvectorp);
3076 staticpro (&Qchar_or_string_p);
3077 staticpro (&Qmarkerp);
3078 staticpro (&Qbuffer_or_string_p);
3079 staticpro (&Qinteger_or_marker_p);
3080 staticpro (&Qfloatp);
3081 staticpro (&Qnumberp);
3082 staticpro (&Qnumber_or_marker_p);
3083 staticpro (&Qchar_table_p);
3084 staticpro (&Qvector_or_char_table_p);
3085 staticpro (&Qsubrp);
3086 staticpro (&Qmany);
3087 staticpro (&Qunevalled);
3089 staticpro (&Qboundp);
3090 staticpro (&Qfboundp);
3091 staticpro (&Qcdr);
3092 staticpro (&Qad_advice_info);
3093 staticpro (&Qad_activate_internal);
3095 /* Types that type-of returns. */
3096 Qinteger = intern ("integer");
3097 Qsymbol = intern ("symbol");
3098 Qstring = intern ("string");
3099 Qcons = intern ("cons");
3100 Qmarker = intern ("marker");
3101 Qoverlay = intern ("overlay");
3102 Qfloat = intern ("float");
3103 Qwindow_configuration = intern ("window-configuration");
3104 Qprocess = intern ("process");
3105 Qwindow = intern ("window");
3106 /* Qsubr = intern ("subr"); */
3107 Qcompiled_function = intern ("compiled-function");
3108 Qbuffer = intern ("buffer");
3109 Qframe = intern ("frame");
3110 Qvector = intern ("vector");
3111 Qchar_table = intern ("char-table");
3112 Qbool_vector = intern ("bool-vector");
3113 Qhash_table = intern ("hash-table");
3115 staticpro (&Qinteger);
3116 staticpro (&Qsymbol);
3117 staticpro (&Qstring);
3118 staticpro (&Qcons);
3119 staticpro (&Qmarker);
3120 staticpro (&Qoverlay);
3121 staticpro (&Qfloat);
3122 staticpro (&Qwindow_configuration);
3123 staticpro (&Qprocess);
3124 staticpro (&Qwindow);
3125 /* staticpro (&Qsubr); */
3126 staticpro (&Qcompiled_function);
3127 staticpro (&Qbuffer);
3128 staticpro (&Qframe);
3129 staticpro (&Qvector);
3130 staticpro (&Qchar_table);
3131 staticpro (&Qbool_vector);
3132 staticpro (&Qhash_table);
3134 defsubr (&Sindirect_variable);
3135 defsubr (&Sinteractive_form);
3136 defsubr (&Seq);
3137 defsubr (&Snull);
3138 defsubr (&Stype_of);
3139 defsubr (&Slistp);
3140 defsubr (&Snlistp);
3141 defsubr (&Sconsp);
3142 defsubr (&Satom);
3143 defsubr (&Sintegerp);
3144 defsubr (&Sinteger_or_marker_p);
3145 defsubr (&Snumberp);
3146 defsubr (&Snumber_or_marker_p);
3147 defsubr (&Sfloatp);
3148 defsubr (&Snatnump);
3149 defsubr (&Ssymbolp);
3150 defsubr (&Skeywordp);
3151 defsubr (&Sstringp);
3152 defsubr (&Smultibyte_string_p);
3153 defsubr (&Svectorp);
3154 defsubr (&Schar_table_p);
3155 defsubr (&Svector_or_char_table_p);
3156 defsubr (&Sbool_vector_p);
3157 defsubr (&Sarrayp);
3158 defsubr (&Ssequencep);
3159 defsubr (&Sbufferp);
3160 defsubr (&Smarkerp);
3161 defsubr (&Ssubrp);
3162 defsubr (&Sbyte_code_function_p);
3163 defsubr (&Schar_or_string_p);
3164 defsubr (&Scar);
3165 defsubr (&Scdr);
3166 defsubr (&Scar_safe);
3167 defsubr (&Scdr_safe);
3168 defsubr (&Ssetcar);
3169 defsubr (&Ssetcdr);
3170 defsubr (&Ssymbol_function);
3171 defsubr (&Sindirect_function);
3172 defsubr (&Ssymbol_plist);
3173 defsubr (&Ssymbol_name);
3174 defsubr (&Smakunbound);
3175 defsubr (&Sfmakunbound);
3176 defsubr (&Sboundp);
3177 defsubr (&Sfboundp);
3178 defsubr (&Sfset);
3179 defsubr (&Sdefalias);
3180 defsubr (&Ssetplist);
3181 defsubr (&Ssymbol_value);
3182 defsubr (&Sset);
3183 defsubr (&Sdefault_boundp);
3184 defsubr (&Sdefault_value);
3185 defsubr (&Sset_default);
3186 defsubr (&Ssetq_default);
3187 defsubr (&Smake_variable_buffer_local);
3188 defsubr (&Smake_local_variable);
3189 defsubr (&Skill_local_variable);
3190 defsubr (&Smake_variable_frame_local);
3191 defsubr (&Slocal_variable_p);
3192 defsubr (&Slocal_variable_if_set_p);
3193 defsubr (&Svariable_binding_locus);
3194 #if 0 /* XXX Remove this. --lorentey */
3195 defsubr (&Sterminal_local_value);
3196 defsubr (&Sset_terminal_local_value);
3197 #endif
3198 defsubr (&Saref);
3199 defsubr (&Saset);
3200 defsubr (&Snumber_to_string);
3201 defsubr (&Sstring_to_number);
3202 defsubr (&Seqlsign);
3203 defsubr (&Slss);
3204 defsubr (&Sgtr);
3205 defsubr (&Sleq);
3206 defsubr (&Sgeq);
3207 defsubr (&Sneq);
3208 defsubr (&Szerop);
3209 defsubr (&Splus);
3210 defsubr (&Sminus);
3211 defsubr (&Stimes);
3212 defsubr (&Squo);
3213 defsubr (&Srem);
3214 defsubr (&Smod);
3215 defsubr (&Smax);
3216 defsubr (&Smin);
3217 defsubr (&Slogand);
3218 defsubr (&Slogior);
3219 defsubr (&Slogxor);
3220 defsubr (&Slsh);
3221 defsubr (&Sash);
3222 defsubr (&Sadd1);
3223 defsubr (&Ssub1);
3224 defsubr (&Slognot);
3225 defsubr (&Sbyteorder);
3226 defsubr (&Ssubr_arity);
3227 defsubr (&Ssubr_name);
3229 XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
3231 DEFVAR_LISP ("most-positive-fixnum", &Vmost_positive_fixnum,
3232 doc: /* The largest value that is representable in a Lisp integer. */);
3233 Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
3235 DEFVAR_LISP ("most-negative-fixnum", &Vmost_negative_fixnum,
3236 doc: /* The smallest value that is representable in a Lisp integer. */);
3237 Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
3240 SIGTYPE
3241 arith_error (signo)
3242 int signo;
3244 #if defined(USG) && !defined(POSIX_SIGNALS)
3245 /* USG systems forget handlers when they are used;
3246 must reestablish each time */
3247 signal (signo, arith_error);
3248 #endif /* USG */
3249 #ifdef VMS
3250 /* VMS systems are like USG. */
3251 signal (signo, arith_error);
3252 #endif /* VMS */
3253 #ifdef BSD4_1
3254 sigrelse (SIGFPE);
3255 #else /* not BSD4_1 */
3256 sigsetmask (SIGEMPTYMASK);
3257 #endif /* not BSD4_1 */
3259 SIGNAL_THREAD_CHECK (signo);
3260 xsignal0 (Qarith_error);
3263 void
3264 init_data ()
3266 /* Don't do this if just dumping out.
3267 We don't want to call `signal' in this case
3268 so that we don't have trouble with dumping
3269 signal-delivering routines in an inconsistent state. */
3270 #ifndef CANNOT_DUMP
3271 if (!initialized)
3272 return;
3273 #endif /* CANNOT_DUMP */
3274 signal (SIGFPE, arith_error);
3276 #ifdef uts
3277 signal (SIGEMT, arith_error);
3278 #endif /* uts */
3281 /* arch-tag: 25879798-b84d-479a-9c89-7d148e2109f7
3282 (do not change this comment) */