Merge from gnulib
[emacs.git] / src / data.c
blobc96841aebbf09354f1bc94fe64b1b27d1bbee56b
1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2015 Free Software
3 Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
21 #include <config.h>
22 #include <stdio.h>
24 #include <byteswap.h>
25 #include <count-one-bits.h>
26 #include <count-trailing-zeros.h>
27 #include <intprops.h>
29 #include "lisp.h"
30 #include "puresize.h"
31 #include "character.h"
32 #include "buffer.h"
33 #include "keyboard.h"
34 #include "frame.h"
35 #include "syssignal.h"
36 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
37 #include "font.h"
38 #include "keymap.h"
40 static void swap_in_symval_forwarding (struct Lisp_Symbol *,
41 struct Lisp_Buffer_Local_Value *);
43 static bool
44 BOOLFWDP (union Lisp_Fwd *a)
46 return XFWDTYPE (a) == Lisp_Fwd_Bool;
48 static bool
49 INTFWDP (union Lisp_Fwd *a)
51 return XFWDTYPE (a) == Lisp_Fwd_Int;
53 static bool
54 KBOARD_OBJFWDP (union Lisp_Fwd *a)
56 return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj;
58 static bool
59 OBJFWDP (union Lisp_Fwd *a)
61 return XFWDTYPE (a) == Lisp_Fwd_Obj;
64 static struct Lisp_Boolfwd *
65 XBOOLFWD (union Lisp_Fwd *a)
67 eassert (BOOLFWDP (a));
68 return &a->u_boolfwd;
70 static struct Lisp_Kboard_Objfwd *
71 XKBOARD_OBJFWD (union Lisp_Fwd *a)
73 eassert (KBOARD_OBJFWDP (a));
74 return &a->u_kboard_objfwd;
76 static struct Lisp_Intfwd *
77 XINTFWD (union Lisp_Fwd *a)
79 eassert (INTFWDP (a));
80 return &a->u_intfwd;
82 static struct Lisp_Objfwd *
83 XOBJFWD (union Lisp_Fwd *a)
85 eassert (OBJFWDP (a));
86 return &a->u_objfwd;
89 static void
90 CHECK_SUBR (Lisp_Object x)
92 CHECK_TYPE (SUBRP (x), Qsubrp, x);
95 static void
96 set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found)
98 eassert (found == !EQ (blv->defcell, blv->valcell));
99 blv->found = found;
102 static Lisp_Object
103 blv_value (struct Lisp_Buffer_Local_Value *blv)
105 return XCDR (blv->valcell);
108 static void
109 set_blv_value (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
111 XSETCDR (blv->valcell, val);
114 static void
115 set_blv_where (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
117 blv->where = val;
120 static void
121 set_blv_defcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
123 blv->defcell = val;
126 static void
127 set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
129 blv->valcell = val;
132 static _Noreturn void
133 wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
135 Lisp_Object size1 = make_number (bool_vector_size (a1));
136 Lisp_Object size2 = make_number (bool_vector_size (a2));
137 if (NILP (a3))
138 xsignal2 (Qwrong_length_argument, size1, size2);
139 else
140 xsignal3 (Qwrong_length_argument, size1, size2,
141 make_number (bool_vector_size (a3)));
144 Lisp_Object
145 wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
147 /* If VALUE is not even a valid Lisp object, we'd want to abort here
148 where we can get a backtrace showing where it came from. We used
149 to try and do that by checking the tagbits, but nowadays all
150 tagbits are potentially valid. */
151 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
152 * emacs_abort (); */
154 xsignal2 (Qwrong_type_argument, predicate, value);
157 void
158 pure_write_error (Lisp_Object obj)
160 xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj);
163 void
164 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
166 xsignal2 (Qargs_out_of_range, a1, a2);
169 void
170 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
172 xsignal3 (Qargs_out_of_range, a1, a2, a3);
176 /* Data type predicates. */
178 DEFUN ("eq", Feq, Seq, 2, 2, 0,
179 doc: /* Return t if the two args are the same Lisp object. */
180 attributes: const)
181 (Lisp_Object obj1, Lisp_Object obj2)
183 if (EQ (obj1, obj2))
184 return Qt;
185 return Qnil;
188 DEFUN ("null", Fnull, Snull, 1, 1, 0,
189 doc: /* Return t if OBJECT is nil. */
190 attributes: const)
191 (Lisp_Object object)
193 if (NILP (object))
194 return Qt;
195 return Qnil;
198 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
199 doc: /* Return a symbol representing the type of OBJECT.
200 The symbol returned names the object's basic type;
201 for example, (type-of 1) returns `integer'. */)
202 (Lisp_Object object)
204 switch (XTYPE (object))
206 case_Lisp_Int:
207 return Qinteger;
209 case Lisp_Symbol:
210 return Qsymbol;
212 case Lisp_String:
213 return Qstring;
215 case Lisp_Cons:
216 return Qcons;
218 case Lisp_Misc:
219 switch (XMISCTYPE (object))
221 case Lisp_Misc_Marker:
222 return Qmarker;
223 case Lisp_Misc_Overlay:
224 return Qoverlay;
225 case Lisp_Misc_Float:
226 return Qfloat;
227 case Lisp_Misc_Finalizer:
228 return Qfinalizer;
230 emacs_abort ();
232 case Lisp_Vectorlike:
233 if (WINDOW_CONFIGURATIONP (object))
234 return Qwindow_configuration;
235 if (PROCESSP (object))
236 return Qprocess;
237 if (WINDOWP (object))
238 return Qwindow;
239 if (SUBRP (object))
240 return Qsubr;
241 if (COMPILEDP (object))
242 return Qcompiled_function;
243 if (BUFFERP (object))
244 return Qbuffer;
245 if (CHAR_TABLE_P (object))
246 return Qchar_table;
247 if (BOOL_VECTOR_P (object))
248 return Qbool_vector;
249 if (FRAMEP (object))
250 return Qframe;
251 if (HASH_TABLE_P (object))
252 return Qhash_table;
253 if (FONT_SPEC_P (object))
254 return Qfont_spec;
255 if (FONT_ENTITY_P (object))
256 return Qfont_entity;
257 if (FONT_OBJECT_P (object))
258 return Qfont_object;
259 return Qvector;
261 case Lisp_Float:
262 return Qfloat;
264 default:
265 emacs_abort ();
269 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
270 doc: /* Return t if OBJECT is a cons cell. */
271 attributes: const)
272 (Lisp_Object object)
274 if (CONSP (object))
275 return Qt;
276 return Qnil;
279 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
280 doc: /* Return t if OBJECT is not a cons cell. This includes nil. */
281 attributes: const)
282 (Lisp_Object object)
284 if (CONSP (object))
285 return Qnil;
286 return Qt;
289 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
290 doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
291 Otherwise, return nil. */
292 attributes: const)
293 (Lisp_Object object)
295 if (CONSP (object) || NILP (object))
296 return Qt;
297 return Qnil;
300 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
301 doc: /* Return t if OBJECT is not a list. Lists include nil. */
302 attributes: const)
303 (Lisp_Object object)
305 if (CONSP (object) || NILP (object))
306 return Qnil;
307 return Qt;
310 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
311 doc: /* Return t if OBJECT is a symbol. */
312 attributes: const)
313 (Lisp_Object object)
315 if (SYMBOLP (object))
316 return Qt;
317 return Qnil;
320 /* Define this in C to avoid unnecessarily consing up the symbol
321 name. */
322 DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
323 doc: /* Return t if OBJECT is a keyword.
324 This means that it is a symbol with a print name beginning with `:'
325 interned in the initial obarray. */)
326 (Lisp_Object object)
328 if (SYMBOLP (object)
329 && SREF (SYMBOL_NAME (object), 0) == ':'
330 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
331 return Qt;
332 return Qnil;
335 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
336 doc: /* Return t if OBJECT is a vector. */)
337 (Lisp_Object object)
339 if (VECTORP (object))
340 return Qt;
341 return Qnil;
344 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
345 doc: /* Return t if OBJECT is a string. */
346 attributes: const)
347 (Lisp_Object object)
349 if (STRINGP (object))
350 return Qt;
351 return Qnil;
354 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
355 1, 1, 0,
356 doc: /* Return t if OBJECT is a multibyte string.
357 Return nil if OBJECT is either a unibyte string, or not a string. */)
358 (Lisp_Object object)
360 if (STRINGP (object) && STRING_MULTIBYTE (object))
361 return Qt;
362 return Qnil;
365 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
366 doc: /* Return t if OBJECT is a char-table. */)
367 (Lisp_Object object)
369 if (CHAR_TABLE_P (object))
370 return Qt;
371 return Qnil;
374 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
375 Svector_or_char_table_p, 1, 1, 0,
376 doc: /* Return t if OBJECT is a char-table or vector. */)
377 (Lisp_Object object)
379 if (VECTORP (object) || CHAR_TABLE_P (object))
380 return Qt;
381 return Qnil;
384 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
385 doc: /* Return t if OBJECT is a bool-vector. */)
386 (Lisp_Object object)
388 if (BOOL_VECTOR_P (object))
389 return Qt;
390 return Qnil;
393 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
394 doc: /* Return t if OBJECT is an array (string or vector). */)
395 (Lisp_Object object)
397 if (ARRAYP (object))
398 return Qt;
399 return Qnil;
402 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
403 doc: /* Return t if OBJECT is a sequence (list or array). */)
404 (register Lisp_Object object)
406 if (CONSP (object) || NILP (object) || ARRAYP (object))
407 return Qt;
408 return Qnil;
411 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
412 doc: /* Return t if OBJECT is an editor buffer. */)
413 (Lisp_Object object)
415 if (BUFFERP (object))
416 return Qt;
417 return Qnil;
420 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
421 doc: /* Return t if OBJECT is a marker (editor pointer). */)
422 (Lisp_Object object)
424 if (MARKERP (object))
425 return Qt;
426 return Qnil;
429 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
430 doc: /* Return t if OBJECT is a built-in function. */)
431 (Lisp_Object object)
433 if (SUBRP (object))
434 return Qt;
435 return Qnil;
438 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
439 1, 1, 0,
440 doc: /* Return t if OBJECT is a byte-compiled function object. */)
441 (Lisp_Object object)
443 if (COMPILEDP (object))
444 return Qt;
445 return Qnil;
448 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
449 doc: /* Return t if OBJECT is a character or a string. */
450 attributes: const)
451 (register Lisp_Object object)
453 if (CHARACTERP (object) || STRINGP (object))
454 return Qt;
455 return Qnil;
458 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
459 doc: /* Return t if OBJECT is an integer. */
460 attributes: const)
461 (Lisp_Object object)
463 if (INTEGERP (object))
464 return Qt;
465 return Qnil;
468 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
469 doc: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
470 (register Lisp_Object object)
472 if (MARKERP (object) || INTEGERP (object))
473 return Qt;
474 return Qnil;
477 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
478 doc: /* Return t if OBJECT is a nonnegative integer. */
479 attributes: const)
480 (Lisp_Object object)
482 if (NATNUMP (object))
483 return Qt;
484 return Qnil;
487 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
488 doc: /* Return t if OBJECT is a number (floating point or integer). */
489 attributes: const)
490 (Lisp_Object object)
492 if (NUMBERP (object))
493 return Qt;
494 else
495 return Qnil;
498 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
499 Snumber_or_marker_p, 1, 1, 0,
500 doc: /* Return t if OBJECT is a number or a marker. */)
501 (Lisp_Object object)
503 if (NUMBERP (object) || MARKERP (object))
504 return Qt;
505 return Qnil;
508 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
509 doc: /* Return t if OBJECT is a floating point number. */
510 attributes: const)
511 (Lisp_Object object)
513 if (FLOATP (object))
514 return Qt;
515 return Qnil;
519 /* Extract and set components of lists. */
521 DEFUN ("car", Fcar, Scar, 1, 1, 0,
522 doc: /* Return the car of LIST. If arg is nil, return nil.
523 Error if arg is not nil and not a cons cell. See also `car-safe'.
525 See Info node `(elisp)Cons Cells' for a discussion of related basic
526 Lisp concepts such as car, cdr, cons cell and list. */)
527 (register Lisp_Object list)
529 return CAR (list);
532 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
533 doc: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
534 (Lisp_Object object)
536 return CAR_SAFE (object);
539 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
540 doc: /* Return the cdr of LIST. If arg is nil, return nil.
541 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
543 See Info node `(elisp)Cons Cells' for a discussion of related basic
544 Lisp concepts such as cdr, car, cons cell and list. */)
545 (register Lisp_Object list)
547 return CDR (list);
550 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
551 doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
552 (Lisp_Object object)
554 return CDR_SAFE (object);
557 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
558 doc: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
559 (register Lisp_Object cell, Lisp_Object newcar)
561 CHECK_CONS (cell);
562 CHECK_IMPURE (cell);
563 XSETCAR (cell, newcar);
564 return newcar;
567 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
568 doc: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
569 (register Lisp_Object cell, Lisp_Object newcdr)
571 CHECK_CONS (cell);
572 CHECK_IMPURE (cell);
573 XSETCDR (cell, newcdr);
574 return newcdr;
577 /* Extract and set components of symbols. */
579 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
580 doc: /* Return t if SYMBOL's value is not void.
581 Note that if `lexical-binding' is in effect, this refers to the
582 global value outside of any lexical scope. */)
583 (register Lisp_Object symbol)
585 Lisp_Object valcontents;
586 struct Lisp_Symbol *sym;
587 CHECK_SYMBOL (symbol);
588 sym = XSYMBOL (symbol);
590 start:
591 switch (sym->redirect)
593 case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
594 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
595 case SYMBOL_LOCALIZED:
597 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
598 if (blv->fwd)
599 /* In set_internal, we un-forward vars when their value is
600 set to Qunbound. */
601 return Qt;
602 else
604 swap_in_symval_forwarding (sym, blv);
605 valcontents = blv_value (blv);
607 break;
609 case SYMBOL_FORWARDED:
610 /* In set_internal, we un-forward vars when their value is
611 set to Qunbound. */
612 return Qt;
613 default: emacs_abort ();
616 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
619 /* FIXME: Make it an alias for function-symbol! */
620 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
621 doc: /* Return t if SYMBOL's function definition is not void. */)
622 (register Lisp_Object symbol)
624 CHECK_SYMBOL (symbol);
625 return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt;
628 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
629 doc: /* Make SYMBOL's value be void.
630 Return SYMBOL. */)
631 (register Lisp_Object symbol)
633 CHECK_SYMBOL (symbol);
634 if (SYMBOL_CONSTANT_P (symbol))
635 xsignal1 (Qsetting_constant, symbol);
636 Fset (symbol, Qunbound);
637 return symbol;
640 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
641 doc: /* Make SYMBOL's function definition be nil.
642 Return SYMBOL. */)
643 (register Lisp_Object symbol)
645 CHECK_SYMBOL (symbol);
646 if (NILP (symbol) || EQ (symbol, Qt))
647 xsignal1 (Qsetting_constant, symbol);
648 set_symbol_function (symbol, Qnil);
649 return symbol;
652 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
653 doc: /* Return SYMBOL's function definition, or nil if that is void. */)
654 (register Lisp_Object symbol)
656 CHECK_SYMBOL (symbol);
657 return XSYMBOL (symbol)->function;
660 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
661 doc: /* Return SYMBOL's property list. */)
662 (register Lisp_Object symbol)
664 CHECK_SYMBOL (symbol);
665 return XSYMBOL (symbol)->plist;
668 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
669 doc: /* Return SYMBOL's name, a string. */)
670 (register Lisp_Object symbol)
672 register Lisp_Object name;
674 CHECK_SYMBOL (symbol);
675 name = SYMBOL_NAME (symbol);
676 return name;
679 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
680 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
681 (register Lisp_Object symbol, Lisp_Object definition)
683 register Lisp_Object function;
684 CHECK_SYMBOL (symbol);
686 function = XSYMBOL (symbol)->function;
688 if (!NILP (Vautoload_queue) && !NILP (function))
689 Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
691 if (AUTOLOADP (function))
692 Fput (symbol, Qautoload, XCDR (function));
694 /* Convert to eassert or remove after GC bug is found. In the
695 meantime, check unconditionally, at a slight perf hit. */
696 if (! valid_lisp_object_p (definition))
697 emacs_abort ();
699 set_symbol_function (symbol, definition);
701 return definition;
704 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
705 doc: /* Set SYMBOL's function definition to DEFINITION.
706 Associates the function with the current load file, if any.
707 The optional third argument DOCSTRING specifies the documentation string
708 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
709 determined by DEFINITION.
711 Internally, this normally uses `fset', but if SYMBOL has a
712 `defalias-fset-function' property, the associated value is used instead.
714 The return value is undefined. */)
715 (register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring)
717 CHECK_SYMBOL (symbol);
718 if (!NILP (Vpurify_flag)
719 /* If `definition' is a keymap, immutable (and copying) is wrong. */
720 && !KEYMAPP (definition))
721 definition = Fpurecopy (definition);
724 bool autoload = AUTOLOADP (definition);
725 if (NILP (Vpurify_flag) || !autoload)
726 { /* Only add autoload entries after dumping, because the ones before are
727 not useful and else we get loads of them from the loaddefs.el. */
729 if (AUTOLOADP (XSYMBOL (symbol)->function))
730 /* Remember that the function was already an autoload. */
731 LOADHIST_ATTACH (Fcons (Qt, symbol));
732 LOADHIST_ATTACH (Fcons (autoload ? Qautoload : Qdefun, symbol));
736 { /* Handle automatic advice activation. */
737 Lisp_Object hook = Fget (symbol, Qdefalias_fset_function);
738 if (!NILP (hook))
739 call2 (hook, symbol, definition);
740 else
741 Ffset (symbol, definition);
744 if (!NILP (docstring))
745 Fput (symbol, Qfunction_documentation, docstring);
746 /* We used to return `definition', but now that `defun' and `defmacro' expand
747 to a call to `defalias', we return `symbol' for backward compatibility
748 (bug#11686). */
749 return symbol;
752 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
753 doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
754 (register Lisp_Object symbol, Lisp_Object newplist)
756 CHECK_SYMBOL (symbol);
757 set_symbol_plist (symbol, newplist);
758 return newplist;
761 DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
762 doc: /* Return minimum and maximum number of args allowed for SUBR.
763 SUBR must be a built-in function.
764 The returned value is a pair (MIN . MAX). MIN is the minimum number
765 of args. MAX is the maximum number or the symbol `many', for a
766 function with `&rest' args, or `unevalled' for a special form. */)
767 (Lisp_Object subr)
769 short minargs, maxargs;
770 CHECK_SUBR (subr);
771 minargs = XSUBR (subr)->min_args;
772 maxargs = XSUBR (subr)->max_args;
773 return Fcons (make_number (minargs),
774 maxargs == MANY ? Qmany
775 : maxargs == UNEVALLED ? Qunevalled
776 : make_number (maxargs));
779 DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
780 doc: /* Return name of subroutine SUBR.
781 SUBR must be a built-in function. */)
782 (Lisp_Object subr)
784 const char *name;
785 CHECK_SUBR (subr);
786 name = XSUBR (subr)->symbol_name;
787 return build_string (name);
790 DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
791 doc: /* Return the interactive form of CMD or nil if none.
792 If CMD is not a command, the return value is nil.
793 Value, if non-nil, is a list \(interactive SPEC). */)
794 (Lisp_Object cmd)
796 Lisp_Object fun = indirect_function (cmd); /* Check cycles. */
798 if (NILP (fun))
799 return Qnil;
801 /* Use an `interactive-form' property if present, analogous to the
802 function-documentation property. */
803 fun = cmd;
804 while (SYMBOLP (fun))
806 Lisp_Object tmp = Fget (fun, Qinteractive_form);
807 if (!NILP (tmp))
808 return tmp;
809 else
810 fun = Fsymbol_function (fun);
813 if (SUBRP (fun))
815 const char *spec = XSUBR (fun)->intspec;
816 if (spec)
817 return list2 (Qinteractive,
818 (*spec != '(') ? build_string (spec) :
819 Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
821 else if (COMPILEDP (fun))
823 if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
824 return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
826 else if (AUTOLOADP (fun))
827 return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil));
828 else if (CONSP (fun))
830 Lisp_Object funcar = XCAR (fun);
831 if (EQ (funcar, Qclosure))
832 return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))));
833 else if (EQ (funcar, Qlambda))
834 return Fassq (Qinteractive, Fcdr (XCDR (fun)));
836 return Qnil;
840 /***********************************************************************
841 Getting and Setting Values of Symbols
842 ***********************************************************************/
844 /* Return the symbol holding SYMBOL's value. Signal
845 `cyclic-variable-indirection' if SYMBOL's chain of variable
846 indirections contains a loop. */
848 struct Lisp_Symbol *
849 indirect_variable (struct Lisp_Symbol *symbol)
851 struct Lisp_Symbol *tortoise, *hare;
853 hare = tortoise = symbol;
855 while (hare->redirect == SYMBOL_VARALIAS)
857 hare = SYMBOL_ALIAS (hare);
858 if (hare->redirect != SYMBOL_VARALIAS)
859 break;
861 hare = SYMBOL_ALIAS (hare);
862 tortoise = SYMBOL_ALIAS (tortoise);
864 if (hare == tortoise)
866 Lisp_Object tem;
867 XSETSYMBOL (tem, symbol);
868 xsignal1 (Qcyclic_variable_indirection, tem);
872 return hare;
876 DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
877 doc: /* Return the variable at the end of OBJECT's variable chain.
878 If OBJECT is a symbol, follow its variable indirections (if any), and
879 return the variable at the end of the chain of aliases. See Info node
880 `(elisp)Variable Aliases'.
882 If OBJECT is not a symbol, just return it. If there is a loop in the
883 chain of aliases, signal a `cyclic-variable-indirection' error. */)
884 (Lisp_Object object)
886 if (SYMBOLP (object))
888 struct Lisp_Symbol *sym = indirect_variable (XSYMBOL (object));
889 XSETSYMBOL (object, sym);
891 return object;
895 /* Given the raw contents of a symbol value cell,
896 return the Lisp value of the symbol.
897 This does not handle buffer-local variables; use
898 swap_in_symval_forwarding for that. */
900 Lisp_Object
901 do_symval_forwarding (register union Lisp_Fwd *valcontents)
903 register Lisp_Object val;
904 switch (XFWDTYPE (valcontents))
906 case Lisp_Fwd_Int:
907 XSETINT (val, *XINTFWD (valcontents)->intvar);
908 return val;
910 case Lisp_Fwd_Bool:
911 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
913 case Lisp_Fwd_Obj:
914 return *XOBJFWD (valcontents)->objvar;
916 case Lisp_Fwd_Buffer_Obj:
917 return per_buffer_value (current_buffer,
918 XBUFFER_OBJFWD (valcontents)->offset);
920 case Lisp_Fwd_Kboard_Obj:
921 /* We used to simply use current_kboard here, but from Lisp
922 code, its value is often unexpected. It seems nicer to
923 allow constructions like this to work as intuitively expected:
925 (with-selected-frame frame
926 (define-key local-function-map "\eOP" [f1]))
928 On the other hand, this affects the semantics of
929 last-command and real-last-command, and people may rely on
930 that. I took a quick look at the Lisp codebase, and I
931 don't think anything will break. --lorentey */
932 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
933 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
934 default: emacs_abort ();
938 /* Used to signal a user-friendly error when symbol WRONG is
939 not a member of CHOICE, which should be a list of symbols. */
941 void
942 wrong_choice (Lisp_Object choice, Lisp_Object wrong)
944 ptrdiff_t i = 0, len = XINT (Flength (choice));
945 Lisp_Object obj, *args;
946 AUTO_STRING (one_of, "One of ");
947 AUTO_STRING (comma, ", ");
948 AUTO_STRING (or, " or ");
949 AUTO_STRING (should_be_specified, " should be specified");
951 USE_SAFE_ALLOCA;
952 SAFE_ALLOCA_LISP (args, len * 2 + 1);
954 args[i++] = one_of;
956 for (obj = choice; !NILP (obj); obj = XCDR (obj))
958 args[i++] = SYMBOL_NAME (XCAR (obj));
959 args[i++] = (NILP (XCDR (obj)) ? should_be_specified
960 : NILP (XCDR (XCDR (obj))) ? or : comma);
963 obj = Fconcat (i, args);
964 SAFE_FREE ();
965 xsignal2 (Qerror, obj, wrong);
968 /* Used to signal a user-friendly error if WRONG is not a number or
969 integer/floating-point number outsize of inclusive MIN..MAX range. */
971 static void
972 wrong_range (Lisp_Object min, Lisp_Object max, Lisp_Object wrong)
974 AUTO_STRING (value_should_be_from, "Value should be from ");
975 AUTO_STRING (to, " to ");
976 xsignal2 (Qerror,
977 CALLN (Fconcat, value_should_be_from, Fnumber_to_string (min),
978 to, Fnumber_to_string (max)),
979 wrong);
982 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
983 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
984 buffer-independent contents of the value cell: forwarded just one
985 step past the buffer-localness.
987 BUF non-zero means set the value in buffer BUF instead of the
988 current buffer. This only plays a role for per-buffer variables. */
990 static void
991 store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newval, struct buffer *buf)
993 switch (XFWDTYPE (valcontents))
995 case Lisp_Fwd_Int:
996 CHECK_NUMBER (newval);
997 *XINTFWD (valcontents)->intvar = XINT (newval);
998 break;
1000 case Lisp_Fwd_Bool:
1001 *XBOOLFWD (valcontents)->boolvar = !NILP (newval);
1002 break;
1004 case Lisp_Fwd_Obj:
1005 *XOBJFWD (valcontents)->objvar = newval;
1007 /* If this variable is a default for something stored
1008 in the buffer itself, such as default-fill-column,
1009 find the buffers that don't have local values for it
1010 and update them. */
1011 if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults
1012 && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1))
1014 int offset = ((char *) XOBJFWD (valcontents)->objvar
1015 - (char *) &buffer_defaults);
1016 int idx = PER_BUFFER_IDX (offset);
1018 Lisp_Object tail, buf;
1020 if (idx <= 0)
1021 break;
1023 FOR_EACH_LIVE_BUFFER (tail, buf)
1025 struct buffer *b = XBUFFER (buf);
1027 if (! PER_BUFFER_VALUE_P (b, idx))
1028 set_per_buffer_value (b, offset, newval);
1031 break;
1033 case Lisp_Fwd_Buffer_Obj:
1035 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1036 Lisp_Object predicate = XBUFFER_OBJFWD (valcontents)->predicate;
1038 if (!NILP (newval))
1040 if (SYMBOLP (predicate))
1042 Lisp_Object prop;
1044 if ((prop = Fget (predicate, Qchoice), !NILP (prop)))
1046 if (NILP (Fmemq (newval, prop)))
1047 wrong_choice (prop, newval);
1049 else if ((prop = Fget (predicate, Qrange), !NILP (prop)))
1051 Lisp_Object min = XCAR (prop), max = XCDR (prop);
1053 if (!NUMBERP (newval)
1054 || !NILP (arithcompare (newval, min, ARITH_LESS))
1055 || !NILP (arithcompare (newval, max, ARITH_GRTR)))
1056 wrong_range (min, max, newval);
1058 else if (FUNCTIONP (predicate))
1060 if (NILP (call1 (predicate, newval)))
1061 wrong_type_argument (predicate, newval);
1065 if (buf == NULL)
1066 buf = current_buffer;
1067 set_per_buffer_value (buf, offset, newval);
1069 break;
1071 case Lisp_Fwd_Kboard_Obj:
1073 char *base = (char *) FRAME_KBOARD (SELECTED_FRAME ());
1074 char *p = base + XKBOARD_OBJFWD (valcontents)->offset;
1075 *(Lisp_Object *) p = newval;
1077 break;
1079 default:
1080 emacs_abort (); /* goto def; */
1084 /* Set up SYMBOL to refer to its global binding. This makes it safe
1085 to alter the status of other bindings. BEWARE: this may be called
1086 during the mark phase of GC, where we assume that Lisp_Object slots
1087 of BLV are marked after this function has changed them. */
1089 void
1090 swap_in_global_binding (struct Lisp_Symbol *symbol)
1092 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
1094 /* Unload the previously loaded binding. */
1095 if (blv->fwd)
1096 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1098 /* Select the global binding in the symbol. */
1099 set_blv_valcell (blv, blv->defcell);
1100 if (blv->fwd)
1101 store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL);
1103 /* Indicate that the global binding is set up now. */
1104 set_blv_where (blv, Qnil);
1105 set_blv_found (blv, 0);
1108 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1109 VALCONTENTS is the contents of its value cell,
1110 which points to a struct Lisp_Buffer_Local_Value.
1112 Return the value forwarded one step past the buffer-local stage.
1113 This could be another forwarding pointer. */
1115 static void
1116 swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_Value *blv)
1118 register Lisp_Object tem1;
1120 eassert (blv == SYMBOL_BLV (symbol));
1122 tem1 = blv->where;
1124 if (NILP (tem1)
1125 || (blv->frame_local
1126 ? !EQ (selected_frame, tem1)
1127 : current_buffer != XBUFFER (tem1)))
1130 /* Unload the previously loaded binding. */
1131 tem1 = blv->valcell;
1132 if (blv->fwd)
1133 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1134 /* Choose the new binding. */
1136 Lisp_Object var;
1137 XSETSYMBOL (var, symbol);
1138 if (blv->frame_local)
1140 tem1 = assq_no_quit (var, XFRAME (selected_frame)->param_alist);
1141 set_blv_where (blv, selected_frame);
1143 else
1145 tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
1146 set_blv_where (blv, Fcurrent_buffer ());
1149 if (!(blv->found = !NILP (tem1)))
1150 tem1 = blv->defcell;
1152 /* Load the new binding. */
1153 set_blv_valcell (blv, tem1);
1154 if (blv->fwd)
1155 store_symval_forwarding (blv->fwd, blv_value (blv), NULL);
1159 /* Find the value of a symbol, returning Qunbound if it's not bound.
1160 This is helpful for code which just wants to get a variable's value
1161 if it has one, without signaling an error.
1162 Note that it must not be possible to quit
1163 within this function. Great care is required for this. */
1165 Lisp_Object
1166 find_symbol_value (Lisp_Object symbol)
1168 struct Lisp_Symbol *sym;
1170 CHECK_SYMBOL (symbol);
1171 sym = XSYMBOL (symbol);
1173 start:
1174 switch (sym->redirect)
1176 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1177 case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1178 case SYMBOL_LOCALIZED:
1180 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1181 swap_in_symval_forwarding (sym, blv);
1182 return blv->fwd ? do_symval_forwarding (blv->fwd) : blv_value (blv);
1184 /* FALLTHROUGH */
1185 case SYMBOL_FORWARDED:
1186 return do_symval_forwarding (SYMBOL_FWD (sym));
1187 default: emacs_abort ();
1191 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
1192 doc: /* Return SYMBOL's value. Error if that is void.
1193 Note that if `lexical-binding' is in effect, this returns the
1194 global value outside of any lexical scope. */)
1195 (Lisp_Object symbol)
1197 Lisp_Object val;
1199 val = find_symbol_value (symbol);
1200 if (!EQ (val, Qunbound))
1201 return val;
1203 xsignal1 (Qvoid_variable, symbol);
1206 DEFUN ("set", Fset, Sset, 2, 2, 0,
1207 doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1208 (register Lisp_Object symbol, Lisp_Object newval)
1210 set_internal (symbol, newval, Qnil, 0);
1211 return newval;
1214 /* Store the value NEWVAL into SYMBOL.
1215 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1216 (nil stands for the current buffer/frame).
1218 If BINDFLAG is false, then if this symbol is supposed to become
1219 local in every buffer where it is set, then we make it local.
1220 If BINDFLAG is true, we don't do that. */
1222 void
1223 set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
1224 bool bindflag)
1226 bool voide = EQ (newval, Qunbound);
1227 struct Lisp_Symbol *sym;
1228 Lisp_Object tem1;
1230 /* If restoring in a dead buffer, do nothing. */
1231 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1232 return; */
1234 CHECK_SYMBOL (symbol);
1235 if (SYMBOL_CONSTANT_P (symbol))
1237 if (NILP (Fkeywordp (symbol))
1238 || !EQ (newval, Fsymbol_value (symbol)))
1239 xsignal1 (Qsetting_constant, symbol);
1240 else
1241 /* Allow setting keywords to their own value. */
1242 return;
1245 sym = XSYMBOL (symbol);
1247 start:
1248 switch (sym->redirect)
1250 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1251 case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
1252 case SYMBOL_LOCALIZED:
1254 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1255 if (NILP (where))
1257 if (blv->frame_local)
1258 where = selected_frame;
1259 else
1260 XSETBUFFER (where, current_buffer);
1262 /* If the current buffer is not the buffer whose binding is
1263 loaded, or if there may be frame-local bindings and the frame
1264 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1265 the default binding is loaded, the loaded binding may be the
1266 wrong one. */
1267 if (!EQ (blv->where, where)
1268 /* Also unload a global binding (if the var is local_if_set). */
1269 || (EQ (blv->valcell, blv->defcell)))
1271 /* The currently loaded binding is not necessarily valid.
1272 We need to unload it, and choose a new binding. */
1274 /* Write out `realvalue' to the old loaded binding. */
1275 if (blv->fwd)
1276 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1278 /* Find the new binding. */
1279 XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */
1280 tem1 = assq_no_quit (symbol,
1281 (blv->frame_local
1282 ? XFRAME (where)->param_alist
1283 : BVAR (XBUFFER (where), local_var_alist)));
1284 set_blv_where (blv, where);
1285 blv->found = 1;
1287 if (NILP (tem1))
1289 /* This buffer still sees the default value. */
1291 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1292 or if this is `let' rather than `set',
1293 make CURRENT-ALIST-ELEMENT point to itself,
1294 indicating that we're seeing the default value.
1295 Likewise if the variable has been let-bound
1296 in the current buffer. */
1297 if (bindflag || !blv->local_if_set
1298 || let_shadows_buffer_binding_p (sym))
1300 blv->found = 0;
1301 tem1 = blv->defcell;
1303 /* If it's a local_if_set, being set not bound,
1304 and we're not within a let that was made for this buffer,
1305 create a new buffer-local binding for the variable.
1306 That means, give this buffer a new assoc for a local value
1307 and load that binding. */
1308 else
1310 /* local_if_set is only supported for buffer-local
1311 bindings, not for frame-local bindings. */
1312 eassert (!blv->frame_local);
1313 tem1 = Fcons (symbol, XCDR (blv->defcell));
1314 bset_local_var_alist
1315 (XBUFFER (where),
1316 Fcons (tem1, BVAR (XBUFFER (where), local_var_alist)));
1320 /* Record which binding is now loaded. */
1321 set_blv_valcell (blv, tem1);
1324 /* Store the new value in the cons cell. */
1325 set_blv_value (blv, newval);
1327 if (blv->fwd)
1329 if (voide)
1330 /* If storing void (making the symbol void), forward only through
1331 buffer-local indicator, not through Lisp_Objfwd, etc. */
1332 blv->fwd = NULL;
1333 else
1334 store_symval_forwarding (blv->fwd, newval,
1335 BUFFERP (where)
1336 ? XBUFFER (where) : current_buffer);
1338 break;
1340 case SYMBOL_FORWARDED:
1342 struct buffer *buf
1343 = BUFFERP (where) ? XBUFFER (where) : current_buffer;
1344 union Lisp_Fwd *innercontents = SYMBOL_FWD (sym);
1345 if (BUFFER_OBJFWDP (innercontents))
1347 int offset = XBUFFER_OBJFWD (innercontents)->offset;
1348 int idx = PER_BUFFER_IDX (offset);
1349 if (idx > 0
1350 && !bindflag
1351 && !let_shadows_buffer_binding_p (sym))
1352 SET_PER_BUFFER_VALUE_P (buf, idx, 1);
1355 if (voide)
1356 { /* If storing void (making the symbol void), forward only through
1357 buffer-local indicator, not through Lisp_Objfwd, etc. */
1358 sym->redirect = SYMBOL_PLAINVAL;
1359 SET_SYMBOL_VAL (sym, newval);
1361 else
1362 store_symval_forwarding (/* sym, */ innercontents, newval, buf);
1363 break;
1365 default: emacs_abort ();
1367 return;
1370 /* Access or set a buffer-local symbol's default value. */
1372 /* Return the default value of SYMBOL, but don't check for voidness.
1373 Return Qunbound if it is void. */
1375 static Lisp_Object
1376 default_value (Lisp_Object symbol)
1378 struct Lisp_Symbol *sym;
1380 CHECK_SYMBOL (symbol);
1381 sym = XSYMBOL (symbol);
1383 start:
1384 switch (sym->redirect)
1386 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1387 case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1388 case SYMBOL_LOCALIZED:
1390 /* If var is set up for a buffer that lacks a local value for it,
1391 the current value is nominally the default value.
1392 But the `realvalue' slot may be more up to date, since
1393 ordinary setq stores just that slot. So use that. */
1394 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1395 if (blv->fwd && EQ (blv->valcell, blv->defcell))
1396 return do_symval_forwarding (blv->fwd);
1397 else
1398 return XCDR (blv->defcell);
1400 case SYMBOL_FORWARDED:
1402 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1404 /* For a built-in buffer-local variable, get the default value
1405 rather than letting do_symval_forwarding get the current value. */
1406 if (BUFFER_OBJFWDP (valcontents))
1408 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1409 if (PER_BUFFER_IDX (offset) != 0)
1410 return per_buffer_default (offset);
1413 /* For other variables, get the current value. */
1414 return do_symval_forwarding (valcontents);
1416 default: emacs_abort ();
1420 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1421 doc: /* Return t if SYMBOL has a non-void default value.
1422 This is the value that is seen in buffers that do not have their own values
1423 for this variable. */)
1424 (Lisp_Object symbol)
1426 register Lisp_Object value;
1428 value = default_value (symbol);
1429 return (EQ (value, Qunbound) ? Qnil : Qt);
1432 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1433 doc: /* Return SYMBOL's default value.
1434 This is the value that is seen in buffers that do not have their own values
1435 for this variable. The default value is meaningful for variables with
1436 local bindings in certain buffers. */)
1437 (Lisp_Object symbol)
1439 Lisp_Object value = default_value (symbol);
1440 if (!EQ (value, Qunbound))
1441 return value;
1443 xsignal1 (Qvoid_variable, symbol);
1446 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1447 doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1448 The default value is seen in buffers that do not have their own values
1449 for this variable. */)
1450 (Lisp_Object symbol, Lisp_Object value)
1452 struct Lisp_Symbol *sym;
1454 CHECK_SYMBOL (symbol);
1455 if (SYMBOL_CONSTANT_P (symbol))
1457 if (NILP (Fkeywordp (symbol))
1458 || !EQ (value, Fdefault_value (symbol)))
1459 xsignal1 (Qsetting_constant, symbol);
1460 else
1461 /* Allow setting keywords to their own value. */
1462 return value;
1464 sym = XSYMBOL (symbol);
1466 start:
1467 switch (sym->redirect)
1469 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1470 case SYMBOL_PLAINVAL: return Fset (symbol, value);
1471 case SYMBOL_LOCALIZED:
1473 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1475 /* Store new value into the DEFAULT-VALUE slot. */
1476 XSETCDR (blv->defcell, value);
1478 /* If the default binding is now loaded, set the REALVALUE slot too. */
1479 if (blv->fwd && EQ (blv->defcell, blv->valcell))
1480 store_symval_forwarding (blv->fwd, value, NULL);
1481 return value;
1483 case SYMBOL_FORWARDED:
1485 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1487 /* Handle variables like case-fold-search that have special slots
1488 in the buffer.
1489 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1490 if (BUFFER_OBJFWDP (valcontents))
1492 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1493 int idx = PER_BUFFER_IDX (offset);
1495 set_per_buffer_default (offset, value);
1497 /* If this variable is not always local in all buffers,
1498 set it in the buffers that don't nominally have a local value. */
1499 if (idx > 0)
1501 struct buffer *b;
1503 FOR_EACH_BUFFER (b)
1504 if (!PER_BUFFER_VALUE_P (b, idx))
1505 set_per_buffer_value (b, offset, value);
1507 return value;
1509 else
1510 return Fset (symbol, value);
1512 default: emacs_abort ();
1516 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
1517 doc: /* Set the default value of variable VAR to VALUE.
1518 VAR, the variable name, is literal (not evaluated);
1519 VALUE is an expression: it is evaluated and its value returned.
1520 The default value of a variable is seen in buffers
1521 that do not have their own values for the variable.
1523 More generally, you can use multiple variables and values, as in
1524 (setq-default VAR VALUE VAR VALUE...)
1525 This sets each VAR's default value to the corresponding VALUE.
1526 The VALUE for the Nth VAR can refer to the new default values
1527 of previous VARs.
1528 usage: (setq-default [VAR VALUE]...) */)
1529 (Lisp_Object args)
1531 Lisp_Object args_left, symbol, val;
1532 struct gcpro gcpro1;
1534 args_left = val = args;
1535 GCPRO1 (args);
1537 while (CONSP (args_left))
1539 val = eval_sub (Fcar (XCDR (args_left)));
1540 symbol = XCAR (args_left);
1541 Fset_default (symbol, val);
1542 args_left = Fcdr (XCDR (args_left));
1545 UNGCPRO;
1546 return val;
1549 /* Lisp functions for creating and removing buffer-local variables. */
1551 union Lisp_Val_Fwd
1553 Lisp_Object value;
1554 union Lisp_Fwd *fwd;
1557 static struct Lisp_Buffer_Local_Value *
1558 make_blv (struct Lisp_Symbol *sym, bool forwarded,
1559 union Lisp_Val_Fwd valcontents)
1561 struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
1562 Lisp_Object symbol;
1563 Lisp_Object tem;
1565 XSETSYMBOL (symbol, sym);
1566 tem = Fcons (symbol, (forwarded
1567 ? do_symval_forwarding (valcontents.fwd)
1568 : valcontents.value));
1570 /* Buffer_Local_Values cannot have as realval a buffer-local
1571 or keyboard-local forwarding. */
1572 eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd)));
1573 eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
1574 blv->fwd = forwarded ? valcontents.fwd : NULL;
1575 set_blv_where (blv, Qnil);
1576 blv->frame_local = 0;
1577 blv->local_if_set = 0;
1578 set_blv_defcell (blv, tem);
1579 set_blv_valcell (blv, tem);
1580 set_blv_found (blv, 0);
1581 return blv;
1584 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local,
1585 Smake_variable_buffer_local, 1, 1, "vMake Variable Buffer Local: ",
1586 doc: /* Make VARIABLE become buffer-local whenever it is set.
1587 At any time, the value for the current buffer is in effect,
1588 unless the variable has never been set in this buffer,
1589 in which case the default value is in effect.
1590 Note that binding the variable with `let', or setting it while
1591 a `let'-style binding made in this buffer is in effect,
1592 does not make the variable buffer-local. Return VARIABLE.
1594 This globally affects all uses of this variable, so it belongs together with
1595 the variable declaration, rather than with its uses (if you just want to make
1596 a variable local to the current buffer for one particular use, use
1597 `make-local-variable'). Buffer-local bindings are normally cleared
1598 while setting up a new major mode, unless they have a `permanent-local'
1599 property.
1601 The function `default-value' gets the default value and `set-default' sets it. */)
1602 (register Lisp_Object variable)
1604 struct Lisp_Symbol *sym;
1605 struct Lisp_Buffer_Local_Value *blv = NULL;
1606 union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
1607 bool forwarded IF_LINT (= 0);
1609 CHECK_SYMBOL (variable);
1610 sym = XSYMBOL (variable);
1612 start:
1613 switch (sym->redirect)
1615 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1616 case SYMBOL_PLAINVAL:
1617 forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1618 if (EQ (valcontents.value, Qunbound))
1619 valcontents.value = Qnil;
1620 break;
1621 case SYMBOL_LOCALIZED:
1622 blv = SYMBOL_BLV (sym);
1623 if (blv->frame_local)
1624 error ("Symbol %s may not be buffer-local",
1625 SDATA (SYMBOL_NAME (variable)));
1626 break;
1627 case SYMBOL_FORWARDED:
1628 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1629 if (KBOARD_OBJFWDP (valcontents.fwd))
1630 error ("Symbol %s may not be buffer-local",
1631 SDATA (SYMBOL_NAME (variable)));
1632 else if (BUFFER_OBJFWDP (valcontents.fwd))
1633 return variable;
1634 break;
1635 default: emacs_abort ();
1638 if (sym->constant)
1639 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
1641 if (!blv)
1643 blv = make_blv (sym, forwarded, valcontents);
1644 sym->redirect = SYMBOL_LOCALIZED;
1645 SET_SYMBOL_BLV (sym, blv);
1647 Lisp_Object symbol;
1648 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1649 if (let_shadows_global_binding_p (symbol))
1650 message ("Making %s buffer-local while let-bound!",
1651 SDATA (SYMBOL_NAME (variable)));
1655 blv->local_if_set = 1;
1656 return variable;
1659 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1660 1, 1, "vMake Local Variable: ",
1661 doc: /* Make VARIABLE have a separate value in the current buffer.
1662 Other buffers will continue to share a common default value.
1663 \(The buffer-local value of VARIABLE starts out as the same value
1664 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1665 Return VARIABLE.
1667 If the variable is already arranged to become local when set,
1668 this function causes a local value to exist for this buffer,
1669 just as setting the variable would do.
1671 This function returns VARIABLE, and therefore
1672 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1673 works.
1675 See also `make-variable-buffer-local'.
1677 Do not use `make-local-variable' to make a hook variable buffer-local.
1678 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1679 (Lisp_Object variable)
1681 Lisp_Object tem;
1682 bool forwarded IF_LINT (= 0);
1683 union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
1684 struct Lisp_Symbol *sym;
1685 struct Lisp_Buffer_Local_Value *blv = NULL;
1687 CHECK_SYMBOL (variable);
1688 sym = XSYMBOL (variable);
1690 start:
1691 switch (sym->redirect)
1693 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1694 case SYMBOL_PLAINVAL:
1695 forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break;
1696 case SYMBOL_LOCALIZED:
1697 blv = SYMBOL_BLV (sym);
1698 if (blv->frame_local)
1699 error ("Symbol %s may not be buffer-local",
1700 SDATA (SYMBOL_NAME (variable)));
1701 break;
1702 case SYMBOL_FORWARDED:
1703 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1704 if (KBOARD_OBJFWDP (valcontents.fwd))
1705 error ("Symbol %s may not be buffer-local",
1706 SDATA (SYMBOL_NAME (variable)));
1707 break;
1708 default: emacs_abort ();
1711 if (sym->constant)
1712 error ("Symbol %s may not be buffer-local",
1713 SDATA (SYMBOL_NAME (variable)));
1715 if (blv ? blv->local_if_set
1716 : (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
1718 tem = Fboundp (variable);
1719 /* Make sure the symbol has a local value in this particular buffer,
1720 by setting it to the same value it already has. */
1721 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1722 return variable;
1724 if (!blv)
1726 blv = make_blv (sym, forwarded, valcontents);
1727 sym->redirect = SYMBOL_LOCALIZED;
1728 SET_SYMBOL_BLV (sym, blv);
1730 Lisp_Object symbol;
1731 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1732 if (let_shadows_global_binding_p (symbol))
1733 message ("Making %s local to %s while let-bound!",
1734 SDATA (SYMBOL_NAME (variable)),
1735 SDATA (BVAR (current_buffer, name)));
1739 /* Make sure this buffer has its own value of symbol. */
1740 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1741 tem = Fassq (variable, BVAR (current_buffer, local_var_alist));
1742 if (NILP (tem))
1744 if (let_shadows_buffer_binding_p (sym))
1745 message ("Making %s buffer-local while locally let-bound!",
1746 SDATA (SYMBOL_NAME (variable)));
1748 /* Swap out any local binding for some other buffer, and make
1749 sure the current value is permanently recorded, if it's the
1750 default value. */
1751 find_symbol_value (variable);
1753 bset_local_var_alist
1754 (current_buffer,
1755 Fcons (Fcons (variable, XCDR (blv->defcell)),
1756 BVAR (current_buffer, local_var_alist)));
1758 /* Make sure symbol does not think it is set up for this buffer;
1759 force it to look once again for this buffer's value. */
1760 if (current_buffer == XBUFFER (blv->where))
1761 set_blv_where (blv, Qnil);
1762 set_blv_found (blv, 0);
1765 /* If the symbol forwards into a C variable, then load the binding
1766 for this buffer now. If C code modifies the variable before we
1767 load the binding in, then that new value will clobber the default
1768 binding the next time we unload it. */
1769 if (blv->fwd)
1770 swap_in_symval_forwarding (sym, blv);
1772 return variable;
1775 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1776 1, 1, "vKill Local Variable: ",
1777 doc: /* Make VARIABLE no longer have a separate value in the current buffer.
1778 From now on the default value will apply in this buffer. Return VARIABLE. */)
1779 (register Lisp_Object variable)
1781 register Lisp_Object tem;
1782 struct Lisp_Buffer_Local_Value *blv;
1783 struct Lisp_Symbol *sym;
1785 CHECK_SYMBOL (variable);
1786 sym = XSYMBOL (variable);
1788 start:
1789 switch (sym->redirect)
1791 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1792 case SYMBOL_PLAINVAL: return variable;
1793 case SYMBOL_FORWARDED:
1795 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1796 if (BUFFER_OBJFWDP (valcontents))
1798 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1799 int idx = PER_BUFFER_IDX (offset);
1801 if (idx > 0)
1803 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
1804 set_per_buffer_value (current_buffer, offset,
1805 per_buffer_default (offset));
1808 return variable;
1810 case SYMBOL_LOCALIZED:
1811 blv = SYMBOL_BLV (sym);
1812 if (blv->frame_local)
1813 return variable;
1814 break;
1815 default: emacs_abort ();
1818 /* Get rid of this buffer's alist element, if any. */
1819 XSETSYMBOL (variable, sym); /* Propagate variable indirection. */
1820 tem = Fassq (variable, BVAR (current_buffer, local_var_alist));
1821 if (!NILP (tem))
1822 bset_local_var_alist
1823 (current_buffer,
1824 Fdelq (tem, BVAR (current_buffer, local_var_alist)));
1826 /* If the symbol is set up with the current buffer's binding
1827 loaded, recompute its value. We have to do it now, or else
1828 forwarded objects won't work right. */
1830 Lisp_Object buf; XSETBUFFER (buf, current_buffer);
1831 if (EQ (buf, blv->where))
1833 set_blv_where (blv, Qnil);
1834 blv->found = 0;
1835 find_symbol_value (variable);
1839 return variable;
1842 /* Lisp functions for creating and removing buffer-local variables. */
1844 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1845 when/if this is removed. */
1847 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1848 1, 1, "vMake Variable Frame Local: ",
1849 doc: /* Enable VARIABLE to have frame-local bindings.
1850 This does not create any frame-local bindings for VARIABLE,
1851 it just makes them possible.
1853 A frame-local binding is actually a frame parameter value.
1854 If a frame F has a value for the frame parameter named VARIABLE,
1855 that also acts as a frame-local binding for VARIABLE in F--
1856 provided this function has been called to enable VARIABLE
1857 to have frame-local bindings at all.
1859 The only way to create a frame-local binding for VARIABLE in a frame
1860 is to set the VARIABLE frame parameter of that frame. See
1861 `modify-frame-parameters' for how to set frame parameters.
1863 Note that since Emacs 23.1, variables cannot be both buffer-local and
1864 frame-local any more (buffer-local bindings used to take precedence over
1865 frame-local bindings). */)
1866 (Lisp_Object variable)
1868 bool forwarded;
1869 union Lisp_Val_Fwd valcontents;
1870 struct Lisp_Symbol *sym;
1871 struct Lisp_Buffer_Local_Value *blv = NULL;
1873 CHECK_SYMBOL (variable);
1874 sym = XSYMBOL (variable);
1876 start:
1877 switch (sym->redirect)
1879 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1880 case SYMBOL_PLAINVAL:
1881 forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1882 if (EQ (valcontents.value, Qunbound))
1883 valcontents.value = Qnil;
1884 break;
1885 case SYMBOL_LOCALIZED:
1886 if (SYMBOL_BLV (sym)->frame_local)
1887 return variable;
1888 else
1889 error ("Symbol %s may not be frame-local",
1890 SDATA (SYMBOL_NAME (variable)));
1891 case SYMBOL_FORWARDED:
1892 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1893 if (KBOARD_OBJFWDP (valcontents.fwd) || BUFFER_OBJFWDP (valcontents.fwd))
1894 error ("Symbol %s may not be frame-local",
1895 SDATA (SYMBOL_NAME (variable)));
1896 break;
1897 default: emacs_abort ();
1900 if (sym->constant)
1901 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
1903 blv = make_blv (sym, forwarded, valcontents);
1904 blv->frame_local = 1;
1905 sym->redirect = SYMBOL_LOCALIZED;
1906 SET_SYMBOL_BLV (sym, blv);
1908 Lisp_Object symbol;
1909 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1910 if (let_shadows_global_binding_p (symbol))
1911 message ("Making %s frame-local while let-bound!",
1912 SDATA (SYMBOL_NAME (variable)));
1914 return variable;
1917 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1918 1, 2, 0,
1919 doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1920 BUFFER defaults to the current buffer. */)
1921 (Lisp_Object variable, Lisp_Object buffer)
1923 struct buffer *buf = decode_buffer (buffer);
1924 struct Lisp_Symbol *sym;
1926 CHECK_SYMBOL (variable);
1927 sym = XSYMBOL (variable);
1929 start:
1930 switch (sym->redirect)
1932 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1933 case SYMBOL_PLAINVAL: return Qnil;
1934 case SYMBOL_LOCALIZED:
1936 Lisp_Object tail, elt, tmp;
1937 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1938 XSETBUFFER (tmp, buf);
1939 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1941 if (EQ (blv->where, tmp)) /* The binding is already loaded. */
1942 return blv_found (blv) ? Qt : Qnil;
1943 else
1944 for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
1946 elt = XCAR (tail);
1947 if (EQ (variable, XCAR (elt)))
1949 eassert (!blv->frame_local);
1950 return Qt;
1953 return Qnil;
1955 case SYMBOL_FORWARDED:
1957 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1958 if (BUFFER_OBJFWDP (valcontents))
1960 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1961 int idx = PER_BUFFER_IDX (offset);
1962 if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
1963 return Qt;
1965 return Qnil;
1967 default: emacs_abort ();
1971 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1972 1, 2, 0,
1973 doc: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1974 BUFFER defaults to the current buffer.
1976 More precisely, return non-nil if either VARIABLE already has a local
1977 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1978 `make-variable-buffer-local'). */)
1979 (register Lisp_Object variable, Lisp_Object buffer)
1981 struct Lisp_Symbol *sym;
1983 CHECK_SYMBOL (variable);
1984 sym = XSYMBOL (variable);
1986 start:
1987 switch (sym->redirect)
1989 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1990 case SYMBOL_PLAINVAL: return Qnil;
1991 case SYMBOL_LOCALIZED:
1993 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1994 if (blv->local_if_set)
1995 return Qt;
1996 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1997 return Flocal_variable_p (variable, buffer);
1999 case SYMBOL_FORWARDED:
2000 /* All BUFFER_OBJFWD slots become local if they are set. */
2001 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) ? Qt : Qnil);
2002 default: emacs_abort ();
2006 DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
2007 1, 1, 0,
2008 doc: /* Return a value indicating where VARIABLE's current binding comes from.
2009 If the current binding is buffer-local, the value is the current buffer.
2010 If the current binding is frame-local, the value is the selected frame.
2011 If the current binding is global (the default), the value is nil. */)
2012 (register Lisp_Object variable)
2014 struct Lisp_Symbol *sym;
2016 CHECK_SYMBOL (variable);
2017 sym = XSYMBOL (variable);
2019 /* Make sure the current binding is actually swapped in. */
2020 find_symbol_value (variable);
2022 start:
2023 switch (sym->redirect)
2025 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
2026 case SYMBOL_PLAINVAL: return Qnil;
2027 case SYMBOL_FORWARDED:
2029 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
2030 if (KBOARD_OBJFWDP (valcontents))
2031 return Fframe_terminal (selected_frame);
2032 else if (!BUFFER_OBJFWDP (valcontents))
2033 return Qnil;
2035 /* FALLTHROUGH */
2036 case SYMBOL_LOCALIZED:
2037 /* For a local variable, record both the symbol and which
2038 buffer's or frame's value we are saving. */
2039 if (!NILP (Flocal_variable_p (variable, Qnil)))
2040 return Fcurrent_buffer ();
2041 else if (sym->redirect == SYMBOL_LOCALIZED
2042 && blv_found (SYMBOL_BLV (sym)))
2043 return SYMBOL_BLV (sym)->where;
2044 else
2045 return Qnil;
2046 default: emacs_abort ();
2050 /* This code is disabled now that we use the selected frame to return
2051 keyboard-local-values. */
2052 #if 0
2053 extern struct terminal *get_terminal (Lisp_Object display, int);
2055 DEFUN ("terminal-local-value", Fterminal_local_value,
2056 Sterminal_local_value, 2, 2, 0,
2057 doc: /* Return the terminal-local value of SYMBOL on TERMINAL.
2058 If SYMBOL is not a terminal-local variable, then return its normal
2059 value, like `symbol-value'.
2061 TERMINAL may be a terminal object, a frame, or nil (meaning the
2062 selected frame's terminal device). */)
2063 (Lisp_Object symbol, Lisp_Object terminal)
2065 Lisp_Object result;
2066 struct terminal *t = get_terminal (terminal, 1);
2067 push_kboard (t->kboard);
2068 result = Fsymbol_value (symbol);
2069 pop_kboard ();
2070 return result;
2073 DEFUN ("set-terminal-local-value", Fset_terminal_local_value,
2074 Sset_terminal_local_value, 3, 3, 0,
2075 doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2076 If VARIABLE is not a terminal-local variable, then set its normal
2077 binding, like `set'.
2079 TERMINAL may be a terminal object, a frame, or nil (meaning the
2080 selected frame's terminal device). */)
2081 (Lisp_Object symbol, Lisp_Object terminal, Lisp_Object value)
2083 Lisp_Object result;
2084 struct terminal *t = get_terminal (terminal, 1);
2085 push_kboard (d->kboard);
2086 result = Fset (symbol, value);
2087 pop_kboard ();
2088 return result;
2090 #endif
2092 /* Find the function at the end of a chain of symbol function indirections. */
2094 /* If OBJECT is a symbol, find the end of its function chain and
2095 return the value found there. If OBJECT is not a symbol, just
2096 return it. If there is a cycle in the function chain, signal a
2097 cyclic-function-indirection error.
2099 This is like Findirect_function, except that it doesn't signal an
2100 error if the chain ends up unbound. */
2101 Lisp_Object
2102 indirect_function (register Lisp_Object object)
2104 Lisp_Object tortoise, hare;
2106 hare = tortoise = object;
2108 for (;;)
2110 if (!SYMBOLP (hare) || NILP (hare))
2111 break;
2112 hare = XSYMBOL (hare)->function;
2113 if (!SYMBOLP (hare) || NILP (hare))
2114 break;
2115 hare = XSYMBOL (hare)->function;
2117 tortoise = XSYMBOL (tortoise)->function;
2119 if (EQ (hare, tortoise))
2120 xsignal1 (Qcyclic_function_indirection, object);
2123 return hare;
2126 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
2127 doc: /* Return the function at the end of OBJECT's function chain.
2128 If OBJECT is not a symbol, just return it. Otherwise, follow all
2129 function indirections to find the final function binding and return it.
2130 Signal a cyclic-function-indirection error if there is a loop in the
2131 function chain of symbols. */)
2132 (register Lisp_Object object, Lisp_Object noerror)
2134 Lisp_Object result;
2136 /* Optimize for no indirection. */
2137 result = object;
2138 if (SYMBOLP (result) && !NILP (result)
2139 && (result = XSYMBOL (result)->function, SYMBOLP (result)))
2140 result = indirect_function (result);
2141 if (!NILP (result))
2142 return result;
2144 return Qnil;
2147 /* Extract and set vector and string elements. */
2149 DEFUN ("aref", Faref, Saref, 2, 2, 0,
2150 doc: /* Return the element of ARRAY at index IDX.
2151 ARRAY may be a vector, a string, a char-table, a bool-vector,
2152 or a byte-code object. IDX starts at 0. */)
2153 (register Lisp_Object array, Lisp_Object idx)
2155 register EMACS_INT idxval;
2157 CHECK_NUMBER (idx);
2158 idxval = XINT (idx);
2159 if (STRINGP (array))
2161 int c;
2162 ptrdiff_t idxval_byte;
2164 if (idxval < 0 || idxval >= SCHARS (array))
2165 args_out_of_range (array, idx);
2166 if (! STRING_MULTIBYTE (array))
2167 return make_number ((unsigned char) SREF (array, idxval));
2168 idxval_byte = string_char_to_byte (array, idxval);
2170 c = STRING_CHAR (SDATA (array) + idxval_byte);
2171 return make_number (c);
2173 else if (BOOL_VECTOR_P (array))
2175 if (idxval < 0 || idxval >= bool_vector_size (array))
2176 args_out_of_range (array, idx);
2177 return bool_vector_ref (array, idxval);
2179 else if (CHAR_TABLE_P (array))
2181 CHECK_CHARACTER (idx);
2182 return CHAR_TABLE_REF (array, idxval);
2184 else
2186 ptrdiff_t size = 0;
2187 if (VECTORP (array))
2188 size = ASIZE (array);
2189 else if (COMPILEDP (array))
2190 size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK;
2191 else
2192 wrong_type_argument (Qarrayp, array);
2194 if (idxval < 0 || idxval >= size)
2195 args_out_of_range (array, idx);
2196 return AREF (array, idxval);
2200 DEFUN ("aset", Faset, Saset, 3, 3, 0,
2201 doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
2202 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2203 bool-vector. IDX starts at 0. */)
2204 (register Lisp_Object array, Lisp_Object idx, Lisp_Object newelt)
2206 register EMACS_INT idxval;
2208 CHECK_NUMBER (idx);
2209 idxval = XINT (idx);
2210 CHECK_ARRAY (array, Qarrayp);
2211 CHECK_IMPURE (array);
2213 if (VECTORP (array))
2215 if (idxval < 0 || idxval >= ASIZE (array))
2216 args_out_of_range (array, idx);
2217 ASET (array, idxval, newelt);
2219 else if (BOOL_VECTOR_P (array))
2221 if (idxval < 0 || idxval >= bool_vector_size (array))
2222 args_out_of_range (array, idx);
2223 bool_vector_set (array, idxval, !NILP (newelt));
2225 else if (CHAR_TABLE_P (array))
2227 CHECK_CHARACTER (idx);
2228 CHAR_TABLE_SET (array, idxval, newelt);
2230 else
2232 int c;
2234 if (idxval < 0 || idxval >= SCHARS (array))
2235 args_out_of_range (array, idx);
2236 CHECK_CHARACTER (newelt);
2237 c = XFASTINT (newelt);
2239 if (STRING_MULTIBYTE (array))
2241 ptrdiff_t idxval_byte, nbytes;
2242 int prev_bytes, new_bytes;
2243 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
2245 nbytes = SBYTES (array);
2246 idxval_byte = string_char_to_byte (array, idxval);
2247 p1 = SDATA (array) + idxval_byte;
2248 prev_bytes = BYTES_BY_CHAR_HEAD (*p1);
2249 new_bytes = CHAR_STRING (c, p0);
2250 if (prev_bytes != new_bytes)
2252 /* We must relocate the string data. */
2253 ptrdiff_t nchars = SCHARS (array);
2254 USE_SAFE_ALLOCA;
2255 unsigned char *str = SAFE_ALLOCA (nbytes);
2257 memcpy (str, SDATA (array), nbytes);
2258 allocate_string_data (XSTRING (array), nchars,
2259 nbytes + new_bytes - prev_bytes);
2260 memcpy (SDATA (array), str, idxval_byte);
2261 p1 = SDATA (array) + idxval_byte;
2262 memcpy (p1 + new_bytes, str + idxval_byte + prev_bytes,
2263 nbytes - (idxval_byte + prev_bytes));
2264 SAFE_FREE ();
2265 clear_string_char_byte_cache ();
2267 while (new_bytes--)
2268 *p1++ = *p0++;
2270 else
2272 if (! SINGLE_BYTE_CHAR_P (c))
2274 ptrdiff_t i;
2276 for (i = SBYTES (array) - 1; i >= 0; i--)
2277 if (SREF (array, i) >= 0x80)
2278 args_out_of_range (array, newelt);
2279 /* ARRAY is an ASCII string. Convert it to a multibyte
2280 string, and try `aset' again. */
2281 STRING_SET_MULTIBYTE (array);
2282 return Faset (array, idx, newelt);
2284 SSET (array, idxval, c);
2288 return newelt;
2291 /* Arithmetic functions */
2293 Lisp_Object
2294 arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison)
2296 double f1 = 0, f2 = 0;
2297 bool floatp = 0;
2299 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
2300 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
2302 if (FLOATP (num1) || FLOATP (num2))
2304 floatp = 1;
2305 f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
2306 f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
2309 switch (comparison)
2311 case ARITH_EQUAL:
2312 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
2313 return Qt;
2314 return Qnil;
2316 case ARITH_NOTEQUAL:
2317 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
2318 return Qt;
2319 return Qnil;
2321 case ARITH_LESS:
2322 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
2323 return Qt;
2324 return Qnil;
2326 case ARITH_LESS_OR_EQUAL:
2327 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
2328 return Qt;
2329 return Qnil;
2331 case ARITH_GRTR:
2332 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
2333 return Qt;
2334 return Qnil;
2336 case ARITH_GRTR_OR_EQUAL:
2337 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
2338 return Qt;
2339 return Qnil;
2341 default:
2342 emacs_abort ();
2346 static Lisp_Object
2347 arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
2348 enum Arith_Comparison comparison)
2350 ptrdiff_t argnum;
2351 for (argnum = 1; argnum < nargs; ++argnum)
2353 if (EQ (Qnil, arithcompare (args[argnum - 1], args[argnum], comparison)))
2354 return Qnil;
2356 return Qt;
2359 DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
2360 doc: /* Return t if args, all numbers or markers, are equal.
2361 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2362 (ptrdiff_t nargs, Lisp_Object *args)
2364 return arithcompare_driver (nargs, args, ARITH_EQUAL);
2367 DEFUN ("<", Flss, Slss, 1, MANY, 0,
2368 doc: /* Return t if each arg (a number or marker), is less than the next arg.
2369 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2370 (ptrdiff_t nargs, Lisp_Object *args)
2372 return arithcompare_driver (nargs, args, ARITH_LESS);
2375 DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
2376 doc: /* Return t if each arg (a number or marker) is greater than the next arg.
2377 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2378 (ptrdiff_t nargs, Lisp_Object *args)
2380 return arithcompare_driver (nargs, args, ARITH_GRTR);
2383 DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
2384 doc: /* Return t if each arg (a number or marker) is less than or equal to the next.
2385 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2386 (ptrdiff_t nargs, Lisp_Object *args)
2388 return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
2391 DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
2392 doc: /* Return t if each arg (a number or marker) is greater than or equal to the next.
2393 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2394 (ptrdiff_t nargs, Lisp_Object *args)
2396 return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
2399 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
2400 doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2401 (register Lisp_Object num1, Lisp_Object num2)
2403 return arithcompare (num1, num2, ARITH_NOTEQUAL);
2406 /* Convert the cons-of-integers, integer, or float value C to an
2407 unsigned value with maximum value MAX. Signal an error if C does not
2408 have a valid format or is out of range. */
2409 uintmax_t
2410 cons_to_unsigned (Lisp_Object c, uintmax_t max)
2412 bool valid = 0;
2413 uintmax_t val IF_LINT (= 0);
2414 if (INTEGERP (c))
2416 valid = 0 <= XINT (c);
2417 val = XINT (c);
2419 else if (FLOATP (c))
2421 double d = XFLOAT_DATA (c);
2422 if (0 <= d
2423 && d < (max == UINTMAX_MAX ? (double) UINTMAX_MAX + 1 : max + 1))
2425 val = d;
2426 valid = 1;
2429 else if (CONSP (c) && NATNUMP (XCAR (c)))
2431 uintmax_t top = XFASTINT (XCAR (c));
2432 Lisp_Object rest = XCDR (c);
2433 if (top <= UINTMAX_MAX >> 24 >> 16
2434 && CONSP (rest)
2435 && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24
2436 && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16)
2438 uintmax_t mid = XFASTINT (XCAR (rest));
2439 val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest));
2440 valid = 1;
2442 else if (top <= UINTMAX_MAX >> 16)
2444 if (CONSP (rest))
2445 rest = XCAR (rest);
2446 if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16)
2448 val = top << 16 | XFASTINT (rest);
2449 valid = 1;
2454 if (! (valid && val <= max))
2455 error ("Not an in-range integer, float, or cons of integers");
2456 return val;
2459 /* Convert the cons-of-integers, integer, or float value C to a signed
2460 value with extrema MIN and MAX. Signal an error if C does not have
2461 a valid format or is out of range. */
2462 intmax_t
2463 cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
2465 bool valid = 0;
2466 intmax_t val IF_LINT (= 0);
2467 if (INTEGERP (c))
2469 val = XINT (c);
2470 valid = 1;
2472 else if (FLOATP (c))
2474 double d = XFLOAT_DATA (c);
2475 if (min <= d
2476 && d < (max == INTMAX_MAX ? (double) INTMAX_MAX + 1 : max + 1))
2478 val = d;
2479 valid = 1;
2482 else if (CONSP (c) && INTEGERP (XCAR (c)))
2484 intmax_t top = XINT (XCAR (c));
2485 Lisp_Object rest = XCDR (c);
2486 if (INTMAX_MIN >> 24 >> 16 <= top && top <= INTMAX_MAX >> 24 >> 16
2487 && CONSP (rest)
2488 && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24
2489 && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16)
2491 intmax_t mid = XFASTINT (XCAR (rest));
2492 val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest));
2493 valid = 1;
2495 else if (INTMAX_MIN >> 16 <= top && top <= INTMAX_MAX >> 16)
2497 if (CONSP (rest))
2498 rest = XCAR (rest);
2499 if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16)
2501 val = top << 16 | XFASTINT (rest);
2502 valid = 1;
2507 if (! (valid && min <= val && val <= max))
2508 error ("Not an in-range integer, float, or cons of integers");
2509 return val;
2512 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
2513 doc: /* Return the decimal representation of NUMBER as a string.
2514 Uses a minus sign if negative.
2515 NUMBER may be an integer or a floating point number. */)
2516 (Lisp_Object number)
2518 char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))];
2519 int len;
2521 CHECK_NUMBER_OR_FLOAT (number);
2523 if (FLOATP (number))
2524 len = float_to_string (buffer, XFLOAT_DATA (number));
2525 else
2526 len = sprintf (buffer, "%"pI"d", XINT (number));
2528 return make_unibyte_string (buffer, len);
2531 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
2532 doc: /* Parse STRING as a decimal number and return the number.
2533 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2534 STRING cannot be parsed as an integer or floating point number.
2536 If BASE, interpret STRING as a number in that base. If BASE isn't
2537 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2538 If the base used is not 10, STRING is always parsed as an integer. */)
2539 (register Lisp_Object string, Lisp_Object base)
2541 register char *p;
2542 register int b;
2543 Lisp_Object val;
2545 CHECK_STRING (string);
2547 if (NILP (base))
2548 b = 10;
2549 else
2551 CHECK_NUMBER (base);
2552 if (! (2 <= XINT (base) && XINT (base) <= 16))
2553 xsignal1 (Qargs_out_of_range, base);
2554 b = XINT (base);
2557 p = SSDATA (string);
2558 while (*p == ' ' || *p == '\t')
2559 p++;
2561 val = string_to_number (p, b, 1);
2562 return NILP (val) ? make_number (0) : val;
2565 enum arithop
2567 Aadd,
2568 Asub,
2569 Amult,
2570 Adiv,
2571 Alogand,
2572 Alogior,
2573 Alogxor,
2574 Amax,
2575 Amin
2578 static Lisp_Object float_arith_driver (double, ptrdiff_t, enum arithop,
2579 ptrdiff_t, Lisp_Object *);
2580 static Lisp_Object
2581 arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
2583 Lisp_Object val;
2584 ptrdiff_t argnum, ok_args;
2585 EMACS_INT accum = 0;
2586 EMACS_INT next, ok_accum;
2587 bool overflow = 0;
2589 switch (code)
2591 case Alogior:
2592 case Alogxor:
2593 case Aadd:
2594 case Asub:
2595 accum = 0;
2596 break;
2597 case Amult:
2598 accum = 1;
2599 break;
2600 case Alogand:
2601 accum = -1;
2602 break;
2603 default:
2604 break;
2607 for (argnum = 0; argnum < nargs; argnum++)
2609 if (! overflow)
2611 ok_args = argnum;
2612 ok_accum = accum;
2615 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2616 val = args[argnum];
2617 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2619 if (FLOATP (val))
2620 return float_arith_driver (ok_accum, ok_args, code,
2621 nargs, args);
2622 args[argnum] = val;
2623 next = XINT (args[argnum]);
2624 switch (code)
2626 case Aadd:
2627 if (INT_ADD_OVERFLOW (accum, next))
2629 overflow = 1;
2630 accum &= INTMASK;
2632 accum += next;
2633 break;
2634 case Asub:
2635 if (INT_SUBTRACT_OVERFLOW (accum, next))
2637 overflow = 1;
2638 accum &= INTMASK;
2640 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2641 break;
2642 case Amult:
2643 if (INT_MULTIPLY_OVERFLOW (accum, next))
2645 EMACS_UINT a = accum, b = next, ab = a * b;
2646 overflow = 1;
2647 accum = ab & INTMASK;
2649 else
2650 accum *= next;
2651 break;
2652 case Adiv:
2653 if (!argnum)
2654 accum = next;
2655 else
2657 if (next == 0)
2658 xsignal0 (Qarith_error);
2659 accum /= next;
2661 break;
2662 case Alogand:
2663 accum &= next;
2664 break;
2665 case Alogior:
2666 accum |= next;
2667 break;
2668 case Alogxor:
2669 accum ^= next;
2670 break;
2671 case Amax:
2672 if (!argnum || next > accum)
2673 accum = next;
2674 break;
2675 case Amin:
2676 if (!argnum || next < accum)
2677 accum = next;
2678 break;
2682 XSETINT (val, accum);
2683 return val;
2686 #undef isnan
2687 #define isnan(x) ((x) != (x))
2689 static Lisp_Object
2690 float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code,
2691 ptrdiff_t nargs, Lisp_Object *args)
2693 register Lisp_Object val;
2694 double next;
2696 for (; argnum < nargs; argnum++)
2698 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2699 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2701 if (FLOATP (val))
2703 next = XFLOAT_DATA (val);
2705 else
2707 args[argnum] = val; /* runs into a compiler bug. */
2708 next = XINT (args[argnum]);
2710 switch (code)
2712 case Aadd:
2713 accum += next;
2714 break;
2715 case Asub:
2716 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2717 break;
2718 case Amult:
2719 accum *= next;
2720 break;
2721 case Adiv:
2722 if (!argnum)
2723 accum = next;
2724 else
2726 if (! IEEE_FLOATING_POINT && next == 0)
2727 xsignal0 (Qarith_error);
2728 accum /= next;
2730 break;
2731 case Alogand:
2732 case Alogior:
2733 case Alogxor:
2734 return wrong_type_argument (Qinteger_or_marker_p, val);
2735 case Amax:
2736 if (!argnum || isnan (next) || next > accum)
2737 accum = next;
2738 break;
2739 case Amin:
2740 if (!argnum || isnan (next) || next < accum)
2741 accum = next;
2742 break;
2746 return make_float (accum);
2750 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2751 doc: /* Return sum of any number of arguments, which are numbers or markers.
2752 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2753 (ptrdiff_t nargs, Lisp_Object *args)
2755 return arith_driver (Aadd, nargs, args);
2758 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2759 doc: /* Negate number or subtract numbers or markers and return the result.
2760 With one arg, negates it. With more than one arg,
2761 subtracts all but the first from the first.
2762 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2763 (ptrdiff_t nargs, Lisp_Object *args)
2765 return arith_driver (Asub, nargs, args);
2768 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2769 doc: /* Return product of any number of arguments, which are numbers or markers.
2770 usage: (* &rest NUMBERS-OR-MARKERS) */)
2771 (ptrdiff_t nargs, Lisp_Object *args)
2773 return arith_driver (Amult, nargs, args);
2776 DEFUN ("/", Fquo, Squo, 1, MANY, 0,
2777 doc: /* Return first argument divided by all the remaining arguments.
2778 The arguments must be numbers or markers.
2779 usage: (/ DIVIDEND &rest DIVISORS) */)
2780 (ptrdiff_t nargs, Lisp_Object *args)
2782 ptrdiff_t argnum;
2783 for (argnum = 2; argnum < nargs; argnum++)
2784 if (FLOATP (args[argnum]))
2785 return float_arith_driver (0, 0, Adiv, nargs, args);
2786 return arith_driver (Adiv, nargs, args);
2789 DEFUN ("%", Frem, Srem, 2, 2, 0,
2790 doc: /* Return remainder of X divided by Y.
2791 Both must be integers or markers. */)
2792 (register Lisp_Object x, Lisp_Object y)
2794 Lisp_Object val;
2796 CHECK_NUMBER_COERCE_MARKER (x);
2797 CHECK_NUMBER_COERCE_MARKER (y);
2799 if (XINT (y) == 0)
2800 xsignal0 (Qarith_error);
2802 XSETINT (val, XINT (x) % XINT (y));
2803 return val;
2806 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2807 doc: /* Return X modulo Y.
2808 The result falls between zero (inclusive) and Y (exclusive).
2809 Both X and Y must be numbers or markers. */)
2810 (register Lisp_Object x, Lisp_Object y)
2812 Lisp_Object val;
2813 EMACS_INT i1, i2;
2815 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
2816 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
2818 if (FLOATP (x) || FLOATP (y))
2819 return fmod_float (x, y);
2821 i1 = XINT (x);
2822 i2 = XINT (y);
2824 if (i2 == 0)
2825 xsignal0 (Qarith_error);
2827 i1 %= i2;
2829 /* If the "remainder" comes out with the wrong sign, fix it. */
2830 if (i2 < 0 ? i1 > 0 : i1 < 0)
2831 i1 += i2;
2833 XSETINT (val, i1);
2834 return val;
2837 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2838 doc: /* Return largest of all the arguments (which must be numbers or markers).
2839 The value is always a number; markers are converted to numbers.
2840 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2841 (ptrdiff_t nargs, Lisp_Object *args)
2843 return arith_driver (Amax, nargs, args);
2846 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2847 doc: /* Return smallest of all the arguments (which must be numbers or markers).
2848 The value is always a number; markers are converted to numbers.
2849 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2850 (ptrdiff_t nargs, Lisp_Object *args)
2852 return arith_driver (Amin, nargs, args);
2855 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2856 doc: /* Return bitwise-and of all the arguments.
2857 Arguments may be integers, or markers converted to integers.
2858 usage: (logand &rest INTS-OR-MARKERS) */)
2859 (ptrdiff_t nargs, Lisp_Object *args)
2861 return arith_driver (Alogand, nargs, args);
2864 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2865 doc: /* Return bitwise-or of all the arguments.
2866 Arguments may be integers, or markers converted to integers.
2867 usage: (logior &rest INTS-OR-MARKERS) */)
2868 (ptrdiff_t nargs, Lisp_Object *args)
2870 return arith_driver (Alogior, nargs, args);
2873 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2874 doc: /* Return bitwise-exclusive-or of all the arguments.
2875 Arguments may be integers, or markers converted to integers.
2876 usage: (logxor &rest INTS-OR-MARKERS) */)
2877 (ptrdiff_t nargs, Lisp_Object *args)
2879 return arith_driver (Alogxor, nargs, args);
2882 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2883 doc: /* Return VALUE with its bits shifted left by COUNT.
2884 If COUNT is negative, shifting is actually to the right.
2885 In this case, the sign bit is duplicated. */)
2886 (register Lisp_Object value, Lisp_Object count)
2888 register Lisp_Object val;
2890 CHECK_NUMBER (value);
2891 CHECK_NUMBER (count);
2893 if (XINT (count) >= BITS_PER_EMACS_INT)
2894 XSETINT (val, 0);
2895 else if (XINT (count) > 0)
2896 XSETINT (val, XUINT (value) << XFASTINT (count));
2897 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2898 XSETINT (val, XINT (value) < 0 ? -1 : 0);
2899 else
2900 XSETINT (val, XINT (value) >> -XINT (count));
2901 return val;
2904 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2905 doc: /* Return VALUE with its bits shifted left by COUNT.
2906 If COUNT is negative, shifting is actually to the right.
2907 In this case, zeros are shifted in on the left. */)
2908 (register Lisp_Object value, Lisp_Object count)
2910 register Lisp_Object val;
2912 CHECK_NUMBER (value);
2913 CHECK_NUMBER (count);
2915 if (XINT (count) >= BITS_PER_EMACS_INT)
2916 XSETINT (val, 0);
2917 else if (XINT (count) > 0)
2918 XSETINT (val, XUINT (value) << XFASTINT (count));
2919 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2920 XSETINT (val, 0);
2921 else
2922 XSETINT (val, XUINT (value) >> -XINT (count));
2923 return val;
2926 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2927 doc: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2928 Markers are converted to integers. */)
2929 (register Lisp_Object number)
2931 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2933 if (FLOATP (number))
2934 return (make_float (1.0 + XFLOAT_DATA (number)));
2936 XSETINT (number, XINT (number) + 1);
2937 return number;
2940 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
2941 doc: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2942 Markers are converted to integers. */)
2943 (register Lisp_Object number)
2945 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2947 if (FLOATP (number))
2948 return (make_float (-1.0 + XFLOAT_DATA (number)));
2950 XSETINT (number, XINT (number) - 1);
2951 return number;
2954 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2955 doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2956 (register Lisp_Object number)
2958 CHECK_NUMBER (number);
2959 XSETINT (number, ~XINT (number));
2960 return number;
2963 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
2964 doc: /* Return the byteorder for the machine.
2965 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2966 lowercase l) for small endian machines. */
2967 attributes: const)
2968 (void)
2970 unsigned i = 0x04030201;
2971 int order = *(char *)&i == 1 ? 108 : 66;
2973 return make_number (order);
2976 /* Because we round up the bool vector allocate size to word_size
2977 units, we can safely read past the "end" of the vector in the
2978 operations below. These extra bits are always zero. */
2980 static bits_word
2981 bool_vector_spare_mask (EMACS_INT nr_bits)
2983 return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1;
2986 /* Info about unsigned long long, falling back on unsigned long
2987 if unsigned long long is not available. */
2989 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2990 enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long long) };
2991 # define ULL_MAX ULLONG_MAX
2992 #else
2993 enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long) };
2994 # define ULL_MAX ULONG_MAX
2995 # define count_one_bits_ll count_one_bits_l
2996 # define count_trailing_zeros_ll count_trailing_zeros_l
2997 #endif
2999 /* Shift VAL right by the width of an unsigned long long.
3000 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
3002 static bits_word
3003 shift_right_ull (bits_word w)
3005 /* Pacify bogus GCC warning about shift count exceeding type width. */
3006 int shift = BITS_PER_ULL - BITS_PER_BITS_WORD < 0 ? BITS_PER_ULL : 0;
3007 return w >> shift;
3010 /* Return the number of 1 bits in W. */
3012 static int
3013 count_one_bits_word (bits_word w)
3015 if (BITS_WORD_MAX <= UINT_MAX)
3016 return count_one_bits (w);
3017 else if (BITS_WORD_MAX <= ULONG_MAX)
3018 return count_one_bits_l (w);
3019 else
3021 int i = 0, count = 0;
3022 while (count += count_one_bits_ll (w),
3023 (i += BITS_PER_ULL) < BITS_PER_BITS_WORD)
3024 w = shift_right_ull (w);
3025 return count;
3029 enum bool_vector_op { bool_vector_exclusive_or,
3030 bool_vector_union,
3031 bool_vector_intersection,
3032 bool_vector_set_difference,
3033 bool_vector_subsetp };
3035 static Lisp_Object
3036 bool_vector_binop_driver (Lisp_Object a,
3037 Lisp_Object b,
3038 Lisp_Object dest,
3039 enum bool_vector_op op)
3041 EMACS_INT nr_bits;
3042 bits_word *adata, *bdata, *destdata;
3043 ptrdiff_t i = 0;
3044 ptrdiff_t nr_words;
3046 CHECK_BOOL_VECTOR (a);
3047 CHECK_BOOL_VECTOR (b);
3049 nr_bits = bool_vector_size (a);
3050 if (bool_vector_size (b) != nr_bits)
3051 wrong_length_argument (a, b, dest);
3053 nr_words = bool_vector_words (nr_bits);
3054 adata = bool_vector_data (a);
3055 bdata = bool_vector_data (b);
3057 if (NILP (dest))
3059 dest = make_uninit_bool_vector (nr_bits);
3060 destdata = bool_vector_data (dest);
3062 else
3064 CHECK_BOOL_VECTOR (dest);
3065 destdata = bool_vector_data (dest);
3066 if (bool_vector_size (dest) != nr_bits)
3067 wrong_length_argument (a, b, dest);
3069 switch (op)
3071 case bool_vector_exclusive_or:
3072 for (; i < nr_words; i++)
3073 if (destdata[i] != (adata[i] ^ bdata[i]))
3074 goto set_dest;
3075 break;
3077 case bool_vector_subsetp:
3078 for (; i < nr_words; i++)
3079 if (adata[i] &~ bdata[i])
3080 return Qnil;
3081 return Qt;
3083 case bool_vector_union:
3084 for (; i < nr_words; i++)
3085 if (destdata[i] != (adata[i] | bdata[i]))
3086 goto set_dest;
3087 break;
3089 case bool_vector_intersection:
3090 for (; i < nr_words; i++)
3091 if (destdata[i] != (adata[i] & bdata[i]))
3092 goto set_dest;
3093 break;
3095 case bool_vector_set_difference:
3096 for (; i < nr_words; i++)
3097 if (destdata[i] != (adata[i] &~ bdata[i]))
3098 goto set_dest;
3099 break;
3102 return Qnil;
3105 set_dest:
3106 switch (op)
3108 case bool_vector_exclusive_or:
3109 for (; i < nr_words; i++)
3110 destdata[i] = adata[i] ^ bdata[i];
3111 break;
3113 case bool_vector_union:
3114 for (; i < nr_words; i++)
3115 destdata[i] = adata[i] | bdata[i];
3116 break;
3118 case bool_vector_intersection:
3119 for (; i < nr_words; i++)
3120 destdata[i] = adata[i] & bdata[i];
3121 break;
3123 case bool_vector_set_difference:
3124 for (; i < nr_words; i++)
3125 destdata[i] = adata[i] &~ bdata[i];
3126 break;
3128 default:
3129 eassume (0);
3132 return dest;
3135 /* PRECONDITION must be true. Return VALUE. This odd construction
3136 works around a bogus GCC diagnostic "shift count >= width of type". */
3138 static int
3139 pre_value (bool precondition, int value)
3141 eassume (precondition);
3142 return precondition ? value : 0;
3145 /* Compute the number of trailing zero bits in val. If val is zero,
3146 return the number of bits in val. */
3147 static int
3148 count_trailing_zero_bits (bits_word val)
3150 if (BITS_WORD_MAX == UINT_MAX)
3151 return count_trailing_zeros (val);
3152 if (BITS_WORD_MAX == ULONG_MAX)
3153 return count_trailing_zeros_l (val);
3154 if (BITS_WORD_MAX == ULL_MAX)
3155 return count_trailing_zeros_ll (val);
3157 /* The rest of this code is for the unlikely platform where bits_word differs
3158 in width from unsigned int, unsigned long, and unsigned long long. */
3159 val |= ~ BITS_WORD_MAX;
3160 if (BITS_WORD_MAX <= UINT_MAX)
3161 return count_trailing_zeros (val);
3162 if (BITS_WORD_MAX <= ULONG_MAX)
3163 return count_trailing_zeros_l (val);
3164 else
3166 int count;
3167 for (count = 0;
3168 count < BITS_PER_BITS_WORD - BITS_PER_ULL;
3169 count += BITS_PER_ULL)
3171 if (val & ULL_MAX)
3172 return count + count_trailing_zeros_ll (val);
3173 val = shift_right_ull (val);
3176 if (BITS_PER_BITS_WORD % BITS_PER_ULL != 0
3177 && BITS_WORD_MAX == (bits_word) -1)
3178 val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX,
3179 BITS_PER_BITS_WORD % BITS_PER_ULL);
3180 return count + count_trailing_zeros_ll (val);
3184 static bits_word
3185 bits_word_to_host_endian (bits_word val)
3187 #ifndef WORDS_BIGENDIAN
3188 return val;
3189 #else
3190 if (BITS_WORD_MAX >> 31 == 1)
3191 return bswap_32 (val);
3192 # if HAVE_UNSIGNED_LONG_LONG
3193 if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
3194 return bswap_64 (val);
3195 # endif
3197 int i;
3198 bits_word r = 0;
3199 for (i = 0; i < sizeof val; i++)
3201 r = ((r << 1 << (CHAR_BIT - 1))
3202 | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
3203 val = val >> 1 >> (CHAR_BIT - 1);
3205 return r;
3207 #endif
3210 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
3211 Sbool_vector_exclusive_or, 2, 3, 0,
3212 doc: /* Return A ^ B, bitwise exclusive or.
3213 If optional third argument C is given, store result into C.
3214 A, B, and C must be bool vectors of the same length.
3215 Return the destination vector if it changed or nil otherwise. */)
3216 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3218 return bool_vector_binop_driver (a, b, c, bool_vector_exclusive_or);
3221 DEFUN ("bool-vector-union", Fbool_vector_union,
3222 Sbool_vector_union, 2, 3, 0,
3223 doc: /* Return A | B, bitwise or.
3224 If optional third argument C is given, store result into C.
3225 A, B, and C must be bool vectors of the same length.
3226 Return the destination vector if it changed or nil otherwise. */)
3227 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3229 return bool_vector_binop_driver (a, b, c, bool_vector_union);
3232 DEFUN ("bool-vector-intersection", Fbool_vector_intersection,
3233 Sbool_vector_intersection, 2, 3, 0,
3234 doc: /* Return A & B, bitwise and.
3235 If optional third argument C is given, store result into C.
3236 A, B, and C must be bool vectors of the same length.
3237 Return the destination vector if it changed or nil otherwise. */)
3238 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3240 return bool_vector_binop_driver (a, b, c, bool_vector_intersection);
3243 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference,
3244 Sbool_vector_set_difference, 2, 3, 0,
3245 doc: /* Return A &~ B, set difference.
3246 If optional third argument C is given, store result into C.
3247 A, B, and C must be bool vectors of the same length.
3248 Return the destination vector if it changed or nil otherwise. */)
3249 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3251 return bool_vector_binop_driver (a, b, c, bool_vector_set_difference);
3254 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp,
3255 Sbool_vector_subsetp, 2, 2, 0,
3256 doc: /* Return t if every t value in A is also t in B, nil otherwise.
3257 A and B must be bool vectors of the same length. */)
3258 (Lisp_Object a, Lisp_Object b)
3260 return bool_vector_binop_driver (a, b, b, bool_vector_subsetp);
3263 DEFUN ("bool-vector-not", Fbool_vector_not,
3264 Sbool_vector_not, 1, 2, 0,
3265 doc: /* Compute ~A, set complement.
3266 If optional second argument B is given, store result into B.
3267 A and B must be bool vectors of the same length.
3268 Return the destination vector. */)
3269 (Lisp_Object a, Lisp_Object b)
3271 EMACS_INT nr_bits;
3272 bits_word *bdata, *adata;
3273 ptrdiff_t i;
3275 CHECK_BOOL_VECTOR (a);
3276 nr_bits = bool_vector_size (a);
3278 if (NILP (b))
3279 b = make_uninit_bool_vector (nr_bits);
3280 else
3282 CHECK_BOOL_VECTOR (b);
3283 if (bool_vector_size (b) != nr_bits)
3284 wrong_length_argument (a, b, Qnil);
3287 bdata = bool_vector_data (b);
3288 adata = bool_vector_data (a);
3290 for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++)
3291 bdata[i] = BITS_WORD_MAX & ~adata[i];
3293 if (nr_bits % BITS_PER_BITS_WORD)
3295 bits_word mword = bits_word_to_host_endian (adata[i]);
3296 mword = ~mword;
3297 mword &= bool_vector_spare_mask (nr_bits);
3298 bdata[i] = bits_word_to_host_endian (mword);
3301 return b;
3304 DEFUN ("bool-vector-count-population", Fbool_vector_count_population,
3305 Sbool_vector_count_population, 1, 1, 0,
3306 doc: /* Count how many elements in A are t.
3307 A is a bool vector. To count A's nil elements, subtract the return
3308 value from A's length. */)
3309 (Lisp_Object a)
3311 EMACS_INT count;
3312 EMACS_INT nr_bits;
3313 bits_word *adata;
3314 ptrdiff_t i, nwords;
3316 CHECK_BOOL_VECTOR (a);
3318 nr_bits = bool_vector_size (a);
3319 nwords = bool_vector_words (nr_bits);
3320 count = 0;
3321 adata = bool_vector_data (a);
3323 for (i = 0; i < nwords; i++)
3324 count += count_one_bits_word (adata[i]);
3326 return make_number (count);
3329 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive,
3330 Sbool_vector_count_consecutive, 3, 3, 0,
3331 doc: /* Count how many consecutive elements in A equal B starting at I.
3332 A is a bool vector, B is t or nil, and I is an index into A. */)
3333 (Lisp_Object a, Lisp_Object b, Lisp_Object i)
3335 EMACS_INT count;
3336 EMACS_INT nr_bits;
3337 int offset;
3338 bits_word *adata;
3339 bits_word twiddle;
3340 bits_word mword; /* Machine word. */
3341 ptrdiff_t pos, pos0;
3342 ptrdiff_t nr_words;
3344 CHECK_BOOL_VECTOR (a);
3345 CHECK_NATNUM (i);
3347 nr_bits = bool_vector_size (a);
3348 if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */
3349 args_out_of_range (a, i);
3351 adata = bool_vector_data (a);
3352 nr_words = bool_vector_words (nr_bits);
3353 pos = XFASTINT (i) / BITS_PER_BITS_WORD;
3354 offset = XFASTINT (i) % BITS_PER_BITS_WORD;
3355 count = 0;
3357 /* By XORing with twiddle, we transform the problem of "count
3358 consecutive equal values" into "count the zero bits". The latter
3359 operation usually has hardware support. */
3360 twiddle = NILP (b) ? 0 : BITS_WORD_MAX;
3362 /* Scan the remainder of the mword at the current offset. */
3363 if (pos < nr_words && offset != 0)
3365 mword = bits_word_to_host_endian (adata[pos]);
3366 mword ^= twiddle;
3367 mword >>= offset;
3369 /* Do not count the pad bits. */
3370 mword |= (bits_word) 1 << (BITS_PER_BITS_WORD - offset);
3372 count = count_trailing_zero_bits (mword);
3373 pos++;
3374 if (count + offset < BITS_PER_BITS_WORD)
3375 return make_number (count);
3378 /* Scan whole words until we either reach the end of the vector or
3379 find an mword that doesn't completely match. twiddle is
3380 endian-independent. */
3381 pos0 = pos;
3382 while (pos < nr_words && adata[pos] == twiddle)
3383 pos++;
3384 count += (pos - pos0) * BITS_PER_BITS_WORD;
3386 if (pos < nr_words)
3388 /* If we stopped because of a mismatch, see how many bits match
3389 in the current mword. */
3390 mword = bits_word_to_host_endian (adata[pos]);
3391 mword ^= twiddle;
3392 count += count_trailing_zero_bits (mword);
3394 else if (nr_bits % BITS_PER_BITS_WORD != 0)
3396 /* If we hit the end, we might have overshot our count. Reduce
3397 the total by the number of spare bits at the end of the
3398 vector. */
3399 count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
3402 return make_number (count);
3406 void
3407 syms_of_data (void)
3409 Lisp_Object error_tail, arith_tail;
3411 DEFSYM (Qquote, "quote");
3412 DEFSYM (Qlambda, "lambda");
3413 DEFSYM (Qsubr, "subr");
3414 DEFSYM (Qerror_conditions, "error-conditions");
3415 DEFSYM (Qerror_message, "error-message");
3416 DEFSYM (Qtop_level, "top-level");
3418 DEFSYM (Qerror, "error");
3419 DEFSYM (Quser_error, "user-error");
3420 DEFSYM (Qquit, "quit");
3421 DEFSYM (Qwrong_length_argument, "wrong-length-argument");
3422 DEFSYM (Qwrong_type_argument, "wrong-type-argument");
3423 DEFSYM (Qargs_out_of_range, "args-out-of-range");
3424 DEFSYM (Qvoid_function, "void-function");
3425 DEFSYM (Qcyclic_function_indirection, "cyclic-function-indirection");
3426 DEFSYM (Qcyclic_variable_indirection, "cyclic-variable-indirection");
3427 DEFSYM (Qvoid_variable, "void-variable");
3428 DEFSYM (Qsetting_constant, "setting-constant");
3429 DEFSYM (Qinvalid_read_syntax, "invalid-read-syntax");
3431 DEFSYM (Qinvalid_function, "invalid-function");
3432 DEFSYM (Qwrong_number_of_arguments, "wrong-number-of-arguments");
3433 DEFSYM (Qno_catch, "no-catch");
3434 DEFSYM (Qend_of_file, "end-of-file");
3435 DEFSYM (Qarith_error, "arith-error");
3436 DEFSYM (Qbeginning_of_buffer, "beginning-of-buffer");
3437 DEFSYM (Qend_of_buffer, "end-of-buffer");
3438 DEFSYM (Qbuffer_read_only, "buffer-read-only");
3439 DEFSYM (Qtext_read_only, "text-read-only");
3440 DEFSYM (Qmark_inactive, "mark-inactive");
3442 DEFSYM (Qlistp, "listp");
3443 DEFSYM (Qconsp, "consp");
3444 DEFSYM (Qsymbolp, "symbolp");
3445 DEFSYM (Qkeywordp, "keywordp");
3446 DEFSYM (Qintegerp, "integerp");
3447 DEFSYM (Qnatnump, "natnump");
3448 DEFSYM (Qwholenump, "wholenump");
3449 DEFSYM (Qstringp, "stringp");
3450 DEFSYM (Qarrayp, "arrayp");
3451 DEFSYM (Qsequencep, "sequencep");
3452 DEFSYM (Qbufferp, "bufferp");
3453 DEFSYM (Qvectorp, "vectorp");
3454 DEFSYM (Qbool_vector_p, "bool-vector-p");
3455 DEFSYM (Qchar_or_string_p, "char-or-string-p");
3456 DEFSYM (Qmarkerp, "markerp");
3457 DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
3458 DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p");
3459 DEFSYM (Qboundp, "boundp");
3460 DEFSYM (Qfboundp, "fboundp");
3462 DEFSYM (Qfloatp, "floatp");
3463 DEFSYM (Qnumberp, "numberp");
3464 DEFSYM (Qnumber_or_marker_p, "number-or-marker-p");
3466 DEFSYM (Qchar_table_p, "char-table-p");
3467 DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
3469 DEFSYM (Qsubrp, "subrp");
3470 DEFSYM (Qunevalled, "unevalled");
3471 DEFSYM (Qmany, "many");
3473 DEFSYM (Qcdr, "cdr");
3475 /* Handle automatic advice activation. */
3476 DEFSYM (Qad_advice_info, "ad-advice-info");
3477 DEFSYM (Qad_activate_internal, "ad-activate-internal");
3479 error_tail = pure_cons (Qerror, Qnil);
3481 /* ERROR is used as a signaler for random errors for which nothing else is
3482 right. */
3484 Fput (Qerror, Qerror_conditions,
3485 error_tail);
3486 Fput (Qerror, Qerror_message,
3487 build_pure_c_string ("error"));
3489 #define PUT_ERROR(sym, tail, msg) \
3490 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3491 Fput (sym, Qerror_message, build_pure_c_string (msg))
3493 PUT_ERROR (Qquit, Qnil, "Quit");
3495 PUT_ERROR (Quser_error, error_tail, "");
3496 PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
3497 PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
3498 PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
3499 PUT_ERROR (Qvoid_function, error_tail,
3500 "Symbol's function definition is void");
3501 PUT_ERROR (Qcyclic_function_indirection, error_tail,
3502 "Symbol's chain of function indirections contains a loop");
3503 PUT_ERROR (Qcyclic_variable_indirection, error_tail,
3504 "Symbol's chain of variable indirections contains a loop");
3505 DEFSYM (Qcircular_list, "circular-list");
3506 PUT_ERROR (Qcircular_list, error_tail, "List contains a loop");
3507 PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void");
3508 PUT_ERROR (Qsetting_constant, error_tail,
3509 "Attempt to set a constant symbol");
3510 PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax");
3511 PUT_ERROR (Qinvalid_function, error_tail, "Invalid function");
3512 PUT_ERROR (Qwrong_number_of_arguments, error_tail,
3513 "Wrong number of arguments");
3514 PUT_ERROR (Qno_catch, error_tail, "No catch for tag");
3515 PUT_ERROR (Qend_of_file, error_tail, "End of file during parsing");
3517 arith_tail = pure_cons (Qarith_error, error_tail);
3518 Fput (Qarith_error, Qerror_conditions, arith_tail);
3519 Fput (Qarith_error, Qerror_message, build_pure_c_string ("Arithmetic error"));
3521 PUT_ERROR (Qbeginning_of_buffer, error_tail, "Beginning of buffer");
3522 PUT_ERROR (Qend_of_buffer, error_tail, "End of buffer");
3523 PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only");
3524 PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail),
3525 "Text is read-only");
3527 DEFSYM (Qrange_error, "range-error");
3528 DEFSYM (Qdomain_error, "domain-error");
3529 DEFSYM (Qsingularity_error, "singularity-error");
3530 DEFSYM (Qoverflow_error, "overflow-error");
3531 DEFSYM (Qunderflow_error, "underflow-error");
3533 PUT_ERROR (Qdomain_error, arith_tail, "Arithmetic domain error");
3535 PUT_ERROR (Qrange_error, arith_tail, "Arithmetic range error");
3537 PUT_ERROR (Qsingularity_error, Fcons (Qdomain_error, arith_tail),
3538 "Arithmetic singularity error");
3540 PUT_ERROR (Qoverflow_error, Fcons (Qdomain_error, arith_tail),
3541 "Arithmetic overflow error");
3542 PUT_ERROR (Qunderflow_error, Fcons (Qdomain_error, arith_tail),
3543 "Arithmetic underflow error");
3545 /* Types that type-of returns. */
3546 DEFSYM (Qinteger, "integer");
3547 DEFSYM (Qsymbol, "symbol");
3548 DEFSYM (Qstring, "string");
3549 DEFSYM (Qcons, "cons");
3550 DEFSYM (Qmarker, "marker");
3551 DEFSYM (Qoverlay, "overlay");
3552 DEFSYM (Qfinalizer, "finalizer");
3553 DEFSYM (Qfloat, "float");
3554 DEFSYM (Qwindow_configuration, "window-configuration");
3555 DEFSYM (Qprocess, "process");
3556 DEFSYM (Qwindow, "window");
3557 DEFSYM (Qcompiled_function, "compiled-function");
3558 DEFSYM (Qbuffer, "buffer");
3559 DEFSYM (Qframe, "frame");
3560 DEFSYM (Qvector, "vector");
3561 DEFSYM (Qchar_table, "char-table");
3562 DEFSYM (Qbool_vector, "bool-vector");
3563 DEFSYM (Qhash_table, "hash-table");
3564 DEFSYM (Qmisc, "misc");
3566 DEFSYM (Qdefun, "defun");
3568 DEFSYM (Qfont_spec, "font-spec");
3569 DEFSYM (Qfont_entity, "font-entity");
3570 DEFSYM (Qfont_object, "font-object");
3572 DEFSYM (Qinteractive_form, "interactive-form");
3573 DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
3575 defsubr (&Sindirect_variable);
3576 defsubr (&Sinteractive_form);
3577 defsubr (&Seq);
3578 defsubr (&Snull);
3579 defsubr (&Stype_of);
3580 defsubr (&Slistp);
3581 defsubr (&Snlistp);
3582 defsubr (&Sconsp);
3583 defsubr (&Satom);
3584 defsubr (&Sintegerp);
3585 defsubr (&Sinteger_or_marker_p);
3586 defsubr (&Snumberp);
3587 defsubr (&Snumber_or_marker_p);
3588 defsubr (&Sfloatp);
3589 defsubr (&Snatnump);
3590 defsubr (&Ssymbolp);
3591 defsubr (&Skeywordp);
3592 defsubr (&Sstringp);
3593 defsubr (&Smultibyte_string_p);
3594 defsubr (&Svectorp);
3595 defsubr (&Schar_table_p);
3596 defsubr (&Svector_or_char_table_p);
3597 defsubr (&Sbool_vector_p);
3598 defsubr (&Sarrayp);
3599 defsubr (&Ssequencep);
3600 defsubr (&Sbufferp);
3601 defsubr (&Smarkerp);
3602 defsubr (&Ssubrp);
3603 defsubr (&Sbyte_code_function_p);
3604 defsubr (&Schar_or_string_p);
3605 defsubr (&Scar);
3606 defsubr (&Scdr);
3607 defsubr (&Scar_safe);
3608 defsubr (&Scdr_safe);
3609 defsubr (&Ssetcar);
3610 defsubr (&Ssetcdr);
3611 defsubr (&Ssymbol_function);
3612 defsubr (&Sindirect_function);
3613 defsubr (&Ssymbol_plist);
3614 defsubr (&Ssymbol_name);
3615 defsubr (&Smakunbound);
3616 defsubr (&Sfmakunbound);
3617 defsubr (&Sboundp);
3618 defsubr (&Sfboundp);
3619 defsubr (&Sfset);
3620 defsubr (&Sdefalias);
3621 defsubr (&Ssetplist);
3622 defsubr (&Ssymbol_value);
3623 defsubr (&Sset);
3624 defsubr (&Sdefault_boundp);
3625 defsubr (&Sdefault_value);
3626 defsubr (&Sset_default);
3627 defsubr (&Ssetq_default);
3628 defsubr (&Smake_variable_buffer_local);
3629 defsubr (&Smake_local_variable);
3630 defsubr (&Skill_local_variable);
3631 defsubr (&Smake_variable_frame_local);
3632 defsubr (&Slocal_variable_p);
3633 defsubr (&Slocal_variable_if_set_p);
3634 defsubr (&Svariable_binding_locus);
3635 #if 0 /* XXX Remove this. --lorentey */
3636 defsubr (&Sterminal_local_value);
3637 defsubr (&Sset_terminal_local_value);
3638 #endif
3639 defsubr (&Saref);
3640 defsubr (&Saset);
3641 defsubr (&Snumber_to_string);
3642 defsubr (&Sstring_to_number);
3643 defsubr (&Seqlsign);
3644 defsubr (&Slss);
3645 defsubr (&Sgtr);
3646 defsubr (&Sleq);
3647 defsubr (&Sgeq);
3648 defsubr (&Sneq);
3649 defsubr (&Splus);
3650 defsubr (&Sminus);
3651 defsubr (&Stimes);
3652 defsubr (&Squo);
3653 defsubr (&Srem);
3654 defsubr (&Smod);
3655 defsubr (&Smax);
3656 defsubr (&Smin);
3657 defsubr (&Slogand);
3658 defsubr (&Slogior);
3659 defsubr (&Slogxor);
3660 defsubr (&Slsh);
3661 defsubr (&Sash);
3662 defsubr (&Sadd1);
3663 defsubr (&Ssub1);
3664 defsubr (&Slognot);
3665 defsubr (&Sbyteorder);
3666 defsubr (&Ssubr_arity);
3667 defsubr (&Ssubr_name);
3669 defsubr (&Sbool_vector_exclusive_or);
3670 defsubr (&Sbool_vector_union);
3671 defsubr (&Sbool_vector_intersection);
3672 defsubr (&Sbool_vector_set_difference);
3673 defsubr (&Sbool_vector_not);
3674 defsubr (&Sbool_vector_subsetp);
3675 defsubr (&Sbool_vector_count_consecutive);
3676 defsubr (&Sbool_vector_count_population);
3678 set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
3680 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
3681 doc: /* The largest value that is representable in a Lisp integer. */);
3682 Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
3683 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1;
3685 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum,
3686 doc: /* The smallest value that is representable in a Lisp integer. */);
3687 Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
3688 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1;