root/src/data.c

DEFINITIONS

1. BOOLFWDP
2. INTFWDP
3. KBOARD_OBJFWDP
4. OBJFWDP
5. XBOOLFWD
6. XKBOARD_OBJFWD
7. XFIXNUMFWD
8. XOBJFWD
9. set_blv_found
10. blv_value
11. set_blv_value
12. set_blv_where
13. set_blv_defcell
14. set_blv_valcell
15. wrong_length_argument
16. wrong_type_argument
17. pure_write_error
18. args_out_of_range
19. args_out_of_range_3
20. circular_list
21. DEFUN
22. DEFUN
23. DEFUN
24. DEFUN
25. DEFUN
26. DEFUN
27. DEFUN
28. DEFUN
29. DEFUN
30. DEFUN
31. DEFUN
32. DEFUN
33. DEFUN
34. DEFUN
35. DEFUN
36. DEFUN
37. DEFUN
38. DEFUN
39. DEFUN
40. DEFUN
41. DEFUN
42. DEFUN
43. DEFUN
44. DEFUN
45. DEFUN
46. DEFUN
47. DEFUN
48. DEFUN
49. DEFUN
50. DEFUN
51. DEFUN
52. DEFUN
53. DEFUN
54. DEFUN
55. DEFUN
56. DEFUN
57. DEFUN
58. DEFUN
59. DEFUN
60. DEFUN
61. DEFUN
62. DEFUN
63. DEFUN
64. DEFUN
65. DEFUN
66. DEFUN
67. DEFUN
68. DEFUN
69. DEFUN
70. add_to_function_history
71. defalias
72. DEFUN
73. DEFUN
74. DEFUN
75. DEFUN
76. DEFUN
77. DEFUN
78. DEFUN
79. DEFUN
80. DEFUN
81. indirect_variable
82. DEFUN
83. do_symval_forwarding
84. wrong_choice
85. wrong_range
86. store_symval_forwarding
87. swap_in_global_binding
88. swap_in_symval_forwarding
89. find_symbol_value
90. DEFUN
91. set_internal
92. set_symbol_trapped_write
93. restore_symbol_trapped_write
94. harmonize_variable_watchers
95. DEFUN
96. notify_variable_watchers
97. default_value
98. DEFUN
99. DEFUN
100. set_default_internal
101. make_blv
102. DEFUN
103. DEFUN
104. DEFUN
105. DEFUN
106. indirect_function
107. check_integer_coerce_marker
108. check_number_coerce_marker
109. arithcompare
110. arithcompare_driver
111. cons_to_unsigned
112. cons_to_signed
113. fixnum_to_string
114. DEFUN
115. floating_point_op
116. floatop_arith_driver
117. float_arith_driver
118. bignum_arith_driver
119. arith_driver
120. integer_remainder
121. minmax_driver
122. DEFUN
123. expt_integer
124. DEFUN
125. DEFUN
126. DEFUN
127. DEFUN
128. bool_vector_spare_mask
129. shift_right_ull
130. count_one_bits_word
131. bool_vector_binop_driver
132. pre_value
133. count_trailing_zero_bits
134. bits_word_to_host_endian
135. DEFUN
136. syms_of_data

     1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
     2    Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2023 Free Software
     3    Foundation, Inc.
     4 
     5 This file is part of GNU Emacs.
     6 
     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 (at
    10 your option) any later version.
    11 
    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.
    16 
    17 You should have received a copy of the GNU General Public License
    18 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    19 
    20 
    21 #include <config.h>
    22 
    23 #include <math.h>
    24 #include <stdio.h>
    25 
    26 #include <byteswap.h>
    27 #include <count-one-bits.h>
    28 #include <count-trailing-zeros.h>
    29 #include <intprops.h>
    30 
    31 #include "lisp.h"
    32 #include "bignum.h"
    33 #include "puresize.h"
    34 #include "character.h"
    35 #include "buffer.h"
    36 #include "keyboard.h"
    37 #include "process.h"
    38 #include "frame.h"
    39 #include "keymap.h"
    40 
    41 static void swap_in_symval_forwarding (struct Lisp_Symbol *,
    42                                        struct Lisp_Buffer_Local_Value *);
    43 
    44 static bool
    45 BOOLFWDP (lispfwd a)
    46 {
    47   return XFWDTYPE (a) == Lisp_Fwd_Bool;
    48 }
    49 static bool
    50 INTFWDP (lispfwd a)
    51 {
    52   return XFWDTYPE (a) == Lisp_Fwd_Int;
    53 }
    54 static bool
    55 KBOARD_OBJFWDP (lispfwd a)
    56 {
    57   return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj;
    58 }
    59 static bool
    60 OBJFWDP (lispfwd a)
    61 {
    62   return XFWDTYPE (a) == Lisp_Fwd_Obj;
    63 }
    64 
    65 static struct Lisp_Boolfwd const *
    66 XBOOLFWD (lispfwd a)
    67 {
    68   eassert (BOOLFWDP (a));
    69   return a.fwdptr;
    70 }
    71 static struct Lisp_Kboard_Objfwd const *
    72 XKBOARD_OBJFWD (lispfwd a)
    73 {
    74   eassert (KBOARD_OBJFWDP (a));
    75   return a.fwdptr;
    76 }
    77 static struct Lisp_Intfwd const *
    78 XFIXNUMFWD (lispfwd a)
    79 {
    80   eassert (INTFWDP (a));
    81   return a.fwdptr;
    82 }
    83 static struct Lisp_Objfwd const *
    84 XOBJFWD (lispfwd a)
    85 {
    86   eassert (OBJFWDP (a));
    87   return a.fwdptr;
    88 }
    89 
    90 static void
    91 set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found)
    92 {
    93   eassert (found == !EQ (blv->defcell, blv->valcell));
    94   blv->found = found;
    95 }
    96 
    97 static Lisp_Object
    98 blv_value (struct Lisp_Buffer_Local_Value *blv)
    99 {
   100   return XCDR (blv->valcell);
   101 }
   102 
   103 static void
   104 set_blv_value (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
   105 {
   106   XSETCDR (blv->valcell, val);
   107 }
   108 
   109 static void
   110 set_blv_where (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
   111 {
   112   blv->where = val;
   113 }
   114 
   115 static void
   116 set_blv_defcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
   117 {
   118   blv->defcell = val;
   119 }
   120 
   121 static void
   122 set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
   123 {
   124   blv->valcell = val;
   125 }
   126 
   127 static AVOID
   128 wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
   129 {
   130   Lisp_Object size1 = make_fixnum (bool_vector_size (a1));
   131   Lisp_Object size2 = make_fixnum (bool_vector_size (a2));
   132   if (NILP (a3))
   133     xsignal2 (Qwrong_length_argument, size1, size2);
   134   else
   135     xsignal3 (Qwrong_length_argument, size1, size2,
   136               make_fixnum (bool_vector_size (a3)));
   137 }
   138 
   139 AVOID
   140 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
   141 {
   142   eassert (!TAGGEDP (value, Lisp_Type_Unused0));
   143   xsignal2 (Qwrong_type_argument, predicate, value);
   144 }
   145 
   146 void
   147 pure_write_error (Lisp_Object obj)
   148 {
   149   xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj);
   150 }
   151 
   152 void
   153 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
   154 {
   155   xsignal2 (Qargs_out_of_range, a1, a2);
   156 }
   157 
   158 void
   159 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
   160 {
   161   xsignal3 (Qargs_out_of_range, a1, a2, a3);
   162 }
   163 
   164 void
   165 circular_list (Lisp_Object list)
   166 {
   167   xsignal1 (Qcircular_list, list);
   168 }
   169 
   170 
   171 /* Data type predicates.  */
   172 
   173 DEFUN ("eq", Feq, Seq, 2, 2, 0,
   174        doc: /* Return t if the two args are the same Lisp object.  */
   175        attributes: const)
   176   (Lisp_Object obj1, Lisp_Object obj2)
   177 {
   178   if (EQ (obj1, obj2))
   179     return Qt;
   180   return Qnil;
   181 }
   182 
   183 DEFUN ("null", Fnull, Snull, 1, 1, 0,
   184        doc: /* Return t if OBJECT is nil, and return nil otherwise.  */
   185        attributes: const)
   186   (Lisp_Object object)
   187 {
   188   if (NILP (object))
   189     return Qt;
   190   return Qnil;
   191 }
   192 
   193 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
   194        doc: /* Return a symbol representing the type of OBJECT.
   195 The symbol returned names the object's basic type;
   196 for example, (type-of 1) returns `integer'.  */)
   197   (Lisp_Object object)
   198 {
   199   switch (XTYPE (object))
   200     {
   201     case_Lisp_Int:
   202       return Qinteger;
   203 
   204     case Lisp_Symbol:
   205       return Qsymbol;
   206 
   207     case Lisp_String:
   208       return Qstring;
   209 
   210     case Lisp_Cons:
   211       return Qcons;
   212 
   213     case Lisp_Vectorlike:
   214       /* WARNING!!  Keep 'cl--typeof-types' in sync with this code!!  */
   215       switch (PSEUDOVECTOR_TYPE (XVECTOR (object)))
   216         {
   217         case PVEC_NORMAL_VECTOR: return Qvector;
   218         case PVEC_BIGNUM: return Qinteger;
   219         case PVEC_MARKER: return Qmarker;
   220         case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos;
   221         case PVEC_OVERLAY: return Qoverlay;
   222         case PVEC_FINALIZER: return Qfinalizer;
   223         case PVEC_USER_PTR: return Quser_ptr;
   224         case PVEC_WINDOW_CONFIGURATION: return Qwindow_configuration;
   225         case PVEC_PROCESS: return Qprocess;
   226         case PVEC_WINDOW: return Qwindow;
   227         case PVEC_SUBR: return Qsubr;
   228         case PVEC_COMPILED: return Qcompiled_function;
   229         case PVEC_BUFFER: return Qbuffer;
   230         case PVEC_CHAR_TABLE: return Qchar_table;
   231         case PVEC_BOOL_VECTOR: return Qbool_vector;
   232         case PVEC_FRAME: return Qframe;
   233         case PVEC_HASH_TABLE: return Qhash_table;
   234         case PVEC_FONT:
   235           if (FONT_SPEC_P (object))
   236             return Qfont_spec;
   237           if (FONT_ENTITY_P (object))
   238             return Qfont_entity;
   239           if (FONT_OBJECT_P (object))
   240             return Qfont_object;
   241           else
   242             emacs_abort (); /* return Qfont?  */
   243         case PVEC_THREAD: return Qthread;
   244         case PVEC_MUTEX: return Qmutex;
   245         case PVEC_CONDVAR: return Qcondition_variable;
   246         case PVEC_TERMINAL: return Qterminal;
   247         case PVEC_RECORD:
   248           {
   249             Lisp_Object t = AREF (object, 0);
   250             if (RECORDP (t) && 1 < PVSIZE (t))
   251               /* Return the type name field of the class!  */
   252               return AREF (t, 1);
   253             else
   254               return t;
   255           }
   256         case PVEC_MODULE_FUNCTION:
   257           return Qmodule_function;
   258         case PVEC_NATIVE_COMP_UNIT:
   259           return Qnative_comp_unit;
   260         case PVEC_XWIDGET:
   261           return Qxwidget;
   262         case PVEC_XWIDGET_VIEW:
   263           return Qxwidget_view;
   264         case PVEC_TS_PARSER:
   265           return Qtreesit_parser;
   266         case PVEC_TS_NODE:
   267           return Qtreesit_node;
   268         case PVEC_TS_COMPILED_QUERY:
   269           return Qtreesit_compiled_query;
   270         case PVEC_SQLITE:
   271           return Qsqlite;
   272         /* "Impossible" cases.  */
   273         case PVEC_MISC_PTR:
   274         case PVEC_OTHER:
   275         case PVEC_SUB_CHAR_TABLE:
   276         case PVEC_FREE: ;
   277         }
   278       emacs_abort ();
   279 
   280     case Lisp_Float:
   281       return Qfloat;
   282 
   283     default:
   284       emacs_abort ();
   285     }
   286 }
   287 
   288 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
   289        doc: /* Return t if OBJECT is a cons cell.  */
   290        attributes: const)
   291   (Lisp_Object object)
   292 {
   293   if (CONSP (object))
   294     return Qt;
   295   return Qnil;
   296 }
   297 
   298 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
   299        doc: /* Return t if OBJECT is not a cons cell.  This includes nil.  */
   300        attributes: const)
   301   (Lisp_Object object)
   302 {
   303   if (CONSP (object))
   304     return Qnil;
   305   return Qt;
   306 }
   307 
   308 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
   309        doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
   310 Otherwise, return nil.  */
   311        attributes: const)
   312   (Lisp_Object object)
   313 {
   314   if (CONSP (object) || NILP (object))
   315     return Qt;
   316   return Qnil;
   317 }
   318 
   319 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
   320        doc: /* Return t if OBJECT is not a list.  Lists include nil.  */
   321        attributes: const)
   322   (Lisp_Object object)
   323 {
   324   if (CONSP (object) || NILP (object))
   325     return Qnil;
   326   return Qt;
   327 }
   328 
   329 DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0,
   330        doc: /* Return t if OBJECT is a symbol, but not a symbol together with position.  */
   331        attributes: const)
   332   (Lisp_Object object)
   333 {
   334   if (BARE_SYMBOL_P (object))
   335     return Qt;
   336   return Qnil;
   337 }
   338 
   339 DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0,
   340        doc: /* Return t if OBJECT is a symbol together with position.  */
   341        attributes: const)
   342   (Lisp_Object object)
   343 {
   344   if (SYMBOL_WITH_POS_P (object))
   345     return Qt;
   346   return Qnil;
   347 }
   348 
   349 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
   350        doc: /* Return t if OBJECT is a symbol.  */
   351        attributes: const)
   352   (Lisp_Object object)
   353 {
   354   if (SYMBOLP (object))
   355     return Qt;
   356   return Qnil;
   357 }
   358 
   359 DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
   360        doc: /* Return t if OBJECT is a keyword.
   361 This means that it is a symbol with a print name beginning with `:'
   362 interned in the initial obarray.  */)
   363   (Lisp_Object object)
   364 {
   365   if (SYMBOLP (object)
   366       && SREF (SYMBOL_NAME (object), 0) == ':'
   367       && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
   368     return Qt;
   369   return Qnil;
   370 }
   371 
   372 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
   373        doc: /* Return t if OBJECT is a vector.  */)
   374   (Lisp_Object object)
   375 {
   376   if (VECTORP (object))
   377     return Qt;
   378   return Qnil;
   379 }
   380 
   381 DEFUN ("recordp", Frecordp, Srecordp, 1, 1, 0,
   382        doc: /* Return t if OBJECT is a record.  */)
   383   (Lisp_Object object)
   384 {
   385   if (RECORDP (object))
   386     return Qt;
   387   return Qnil;
   388 }
   389 
   390 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
   391        doc: /* Return t if OBJECT is a string.  */
   392        attributes: const)
   393   (Lisp_Object object)
   394 {
   395   if (STRINGP (object))
   396     return Qt;
   397   return Qnil;
   398 }
   399 
   400 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
   401        1, 1, 0,
   402        doc: /* Return t if OBJECT is a multibyte string.
   403 Return nil if OBJECT is either a unibyte string, or not a string.  */)
   404   (Lisp_Object object)
   405 {
   406   if (STRINGP (object) && STRING_MULTIBYTE (object))
   407     return Qt;
   408   return Qnil;
   409 }
   410 
   411 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
   412        doc: /* Return t if OBJECT is a char-table.  */)
   413   (Lisp_Object object)
   414 {
   415   if (CHAR_TABLE_P (object))
   416     return Qt;
   417   return Qnil;
   418 }
   419 
   420 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
   421        Svector_or_char_table_p, 1, 1, 0,
   422        doc: /* Return t if OBJECT is a char-table or vector.  */)
   423   (Lisp_Object object)
   424 {
   425   if (VECTORP (object) || CHAR_TABLE_P (object))
   426     return Qt;
   427   return Qnil;
   428 }
   429 
   430 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
   431        doc: /* Return t if OBJECT is a bool-vector.  */)
   432   (Lisp_Object object)
   433 {
   434   if (BOOL_VECTOR_P (object))
   435     return Qt;
   436   return Qnil;
   437 }
   438 
   439 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
   440        doc: /* Return t if OBJECT is an array (string or vector).  */)
   441   (Lisp_Object object)
   442 {
   443   if (ARRAYP (object))
   444     return Qt;
   445   return Qnil;
   446 }
   447 
   448 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
   449        doc: /* Return t if OBJECT is a sequence (list or array).  */)
   450   (register Lisp_Object object)
   451 {
   452   if (CONSP (object) || NILP (object) || ARRAYP (object))
   453     return Qt;
   454   return Qnil;
   455 }
   456 
   457 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
   458        doc: /* Return t if OBJECT is an editor buffer.  */)
   459   (Lisp_Object object)
   460 {
   461   if (BUFFERP (object))
   462     return Qt;
   463   return Qnil;
   464 }
   465 
   466 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
   467        doc: /* Return t if OBJECT is a marker (editor pointer).  */)
   468   (Lisp_Object object)
   469 {
   470   if (MARKERP (object))
   471     return Qt;
   472   return Qnil;
   473 }
   474 
   475 #ifdef HAVE_MODULES
   476 DEFUN ("user-ptrp", Fuser_ptrp, Suser_ptrp, 1, 1, 0,
   477        doc: /* Return t if OBJECT is a module user pointer.  */)
   478      (Lisp_Object object)
   479 {
   480   if (USER_PTRP (object))
   481     return Qt;
   482   return Qnil;
   483 }
   484 #endif
   485 
   486 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
   487        doc: /* Return t if OBJECT is a built-in function.  */)
   488   (Lisp_Object object)
   489 {
   490   if (SUBRP (object))
   491     return Qt;
   492   return Qnil;
   493 }
   494 
   495 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
   496        1, 1, 0,
   497        doc: /* Return t if OBJECT is a byte-compiled function object.  */)
   498   (Lisp_Object object)
   499 {
   500   if (COMPILEDP (object))
   501     return Qt;
   502   return Qnil;
   503 }
   504 
   505 DEFUN ("module-function-p", Fmodule_function_p, Smodule_function_p, 1, 1, NULL,
   506        doc: /* Return t if OBJECT is a function loaded from a dynamic module.  */
   507        attributes: const)
   508   (Lisp_Object object)
   509 {
   510   return MODULE_FUNCTIONP (object) ? Qt : Qnil;
   511 }
   512 
   513 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
   514        doc: /* Return t if OBJECT is a character or a string.  */
   515        attributes: const)
   516   (register Lisp_Object object)
   517 {
   518   if (CHARACTERP (object) || STRINGP (object))
   519     return Qt;
   520   return Qnil;
   521 }
   522 
   523 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
   524        doc: /* Return t if OBJECT is an integer.  */
   525        attributes: const)
   526   (Lisp_Object object)
   527 {
   528   if (INTEGERP (object))
   529     return Qt;
   530   return Qnil;
   531 }
   532 
   533 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
   534        doc: /* Return t if OBJECT is an integer or a marker (editor pointer).  */)
   535   (register Lisp_Object object)
   536 {
   537   if (MARKERP (object) || INTEGERP (object))
   538     return Qt;
   539   return Qnil;
   540 }
   541 
   542 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
   543        doc: /* Return t if OBJECT is a nonnegative integer.  */
   544        attributes: const)
   545   (Lisp_Object object)
   546 {
   547   return ((FIXNUMP (object) ? 0 <= XFIXNUM (object)
   548            : BIGNUMP (object) && 0 <= mpz_sgn (*xbignum_val (object)))
   549           ? Qt : Qnil);
   550 }
   551 
   552 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
   553        doc: /* Return t if OBJECT is a number (floating point or integer).  */
   554        attributes: const)
   555   (Lisp_Object object)
   556 {
   557   if (NUMBERP (object))
   558     return Qt;
   559   else
   560     return Qnil;
   561 }
   562 
   563 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
   564        Snumber_or_marker_p, 1, 1, 0,
   565        doc: /* Return t if OBJECT is a number or a marker.  */)
   566   (Lisp_Object object)
   567 {
   568   if (NUMBERP (object) || MARKERP (object))
   569     return Qt;
   570   return Qnil;
   571 }
   572 
   573 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
   574        doc: /* Return t if OBJECT is a floating point number.  */
   575        attributes: const)
   576   (Lisp_Object object)
   577 {
   578   if (FLOATP (object))
   579     return Qt;
   580   return Qnil;
   581 }
   582 
   583 DEFUN ("threadp", Fthreadp, Sthreadp, 1, 1, 0,
   584        doc: /* Return t if OBJECT is a thread.  */)
   585   (Lisp_Object object)
   586 {
   587   if (THREADP (object))
   588     return Qt;
   589   return Qnil;
   590 }
   591 
   592 DEFUN ("mutexp", Fmutexp, Smutexp, 1, 1, 0,
   593        doc: /* Return t if OBJECT is a mutex.  */)
   594   (Lisp_Object object)
   595 {
   596   if (MUTEXP (object))
   597     return Qt;
   598   return Qnil;
   599 }
   600 
   601 DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p,
   602        1, 1, 0,
   603        doc: /* Return t if OBJECT is a condition variable.  */)
   604   (Lisp_Object object)
   605 {
   606   if (CONDVARP (object))
   607     return Qt;
   608   return Qnil;
   609 }
   610 
   611 /* Extract and set components of lists.  */
   612 
   613 DEFUN ("car", Fcar, Scar, 1, 1, 0,
   614        doc: /* Return the car of LIST.  If LIST is nil, return nil.
   615 Error if LIST is not nil and not a cons cell.  See also `car-safe'.
   616 
   617 See Info node `(elisp)Cons Cells' for a discussion of related basic
   618 Lisp concepts such as car, cdr, cons cell and list.  */)
   619   (register Lisp_Object list)
   620 {
   621   return CAR (list);
   622 }
   623 
   624 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
   625        doc: /* Return the car of OBJECT if it is a cons cell, or else nil.  */)
   626   (Lisp_Object object)
   627 {
   628   return CAR_SAFE (object);
   629 }
   630 
   631 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
   632        doc: /* Return the cdr of LIST.  If LIST is nil, return nil.
   633 Error if LIST is not nil and not a cons cell.  See also `cdr-safe'.
   634 
   635 See Info node `(elisp)Cons Cells' for a discussion of related basic
   636 Lisp concepts such as cdr, car, cons cell and list.  */)
   637   (register Lisp_Object list)
   638 {
   639   return CDR (list);
   640 }
   641 
   642 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
   643        doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
   644   (Lisp_Object object)
   645 {
   646   return CDR_SAFE (object);
   647 }
   648 
   649 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
   650        doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
   651   (register Lisp_Object cell, Lisp_Object newcar)
   652 {
   653   CHECK_CONS (cell);
   654   CHECK_IMPURE (cell, XCONS (cell));
   655   XSETCAR (cell, newcar);
   656   return newcar;
   657 }
   658 
   659 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
   660        doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
   661   (register Lisp_Object cell, Lisp_Object newcdr)
   662 {
   663   CHECK_CONS (cell);
   664   CHECK_IMPURE (cell, XCONS (cell));
   665   XSETCDR (cell, newcdr);
   666   return newcdr;
   667 }
   668 
   669 /* Extract and set components of symbols.  */
   670 
   671 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
   672        doc: /* Return t if SYMBOL's value is not void.
   673 Note that if `lexical-binding' is in effect, this refers to the
   674 global value outside of any lexical scope.  */)
   675   (register Lisp_Object symbol)
   676 {
   677   Lisp_Object valcontents;
   678   struct Lisp_Symbol *sym;
   679   CHECK_SYMBOL (symbol);
   680   sym = XSYMBOL (symbol);
   681 
   682  start:
   683   switch (sym->u.s.redirect)
   684     {
   685     case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
   686     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
   687     case SYMBOL_LOCALIZED:
   688       {
   689         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
   690         if (blv->fwd.fwdptr)
   691           /* In set_internal, we un-forward vars when their value is
   692              set to Qunbound.  */
   693           return Qt;
   694         else
   695           {
   696             swap_in_symval_forwarding (sym, blv);
   697             valcontents = blv_value (blv);
   698           }
   699         break;
   700       }
   701     case SYMBOL_FORWARDED:
   702       /* In set_internal, we un-forward vars when their value is
   703          set to Qunbound.  */
   704       return Qt;
   705     default: emacs_abort ();
   706     }
   707 
   708   return (BASE_EQ (valcontents, Qunbound) ? Qnil : Qt);
   709 }
   710 
   711 /* It has been previously suggested to make this function an alias for
   712    symbol-function, but upon discussion at Bug#23957, there is a risk
   713    breaking backward compatibility, as some users of fboundp may
   714    expect t in particular, rather than any true value.  */
   715 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
   716        doc: /* Return t if SYMBOL's function definition is not void.  */)
   717   (Lisp_Object symbol)
   718 {
   719   CHECK_SYMBOL (symbol);
   720   return NILP (XSYMBOL (symbol)->u.s.function) ? Qnil : Qt;
   721 }
   722 
   723 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
   724        doc: /* Empty out the value cell of SYMBOL, making it void as a variable.
   725 Return SYMBOL.
   726 
   727 If a variable is void, trying to evaluate the variable signals a
   728 `void-variable' error, instead of returning a value.  For more
   729 details, see Info node `(elisp) Void Variables'.
   730 
   731 See also `fmakunbound'.  */)
   732   (register Lisp_Object symbol)
   733 {
   734   CHECK_SYMBOL (symbol);
   735   if (SYMBOL_CONSTANT_P (symbol))
   736     xsignal1 (Qsetting_constant, symbol);
   737   Fset (symbol, Qunbound);
   738   return symbol;
   739 }
   740 
   741 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
   742        doc: /* Make SYMBOL's function definition be void.
   743 Return SYMBOL.
   744 
   745 If a function definition is void, trying to call a function by that
   746 name will cause a `void-function' error.  For more details, see Info
   747 node `(elisp) Function Cells'.
   748 
   749 See also `makunbound'.  */)
   750   (register Lisp_Object symbol)
   751 {
   752   CHECK_SYMBOL (symbol);
   753   if (NILP (symbol) || EQ (symbol, Qt))
   754     xsignal1 (Qsetting_constant, symbol);
   755   set_symbol_function (symbol, Qnil);
   756   return symbol;
   757 }
   758 
   759 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
   760        doc: /* Return SYMBOL's function definition, or nil if that is void.  */)
   761   (Lisp_Object symbol)
   762 {
   763   CHECK_SYMBOL (symbol);
   764   return XSYMBOL (symbol)->u.s.function;
   765 }
   766 
   767 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
   768        doc: /* Return SYMBOL's property list.  */)
   769   (Lisp_Object symbol)
   770 {
   771   CHECK_SYMBOL (symbol);
   772   return XSYMBOL (symbol)->u.s.plist;
   773 }
   774 
   775 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
   776        doc: /* Return SYMBOL's name, a string.
   777 
   778 Warning: never alter the string returned by `symbol-name'.
   779 Doing that might make Emacs dysfunctional, and might even crash Emacs.  */)
   780   (register Lisp_Object symbol)
   781 {
   782   register Lisp_Object name;
   783 
   784   CHECK_SYMBOL (symbol);
   785   name = SYMBOL_NAME (symbol);
   786   return name;
   787 }
   788 
   789 DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
   790        doc: /* Extract, if need be, the bare symbol from SYM, a symbol.  */)
   791   (register Lisp_Object sym)
   792 {
   793   if (BARE_SYMBOL_P (sym))
   794     return sym;
   795   /* Type checking is done in the following macro. */
   796   return SYMBOL_WITH_POS_SYM (sym);
   797 }
   798 
   799 DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0,
   800        doc: /* Extract the position from a symbol with position.  */)
   801   (register Lisp_Object ls)
   802 {
   803   /* Type checking is done in the following macro. */
   804   return SYMBOL_WITH_POS_POS (ls);
   805 }
   806 
   807 DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol,
   808        Sremove_pos_from_symbol, 1, 1, 0,
   809        doc: /* If ARG is a symbol with position, return it without the position.
   810 Otherwise, return ARG unchanged.  Compare with `bare-symbol'.  */)
   811   (register Lisp_Object arg)
   812 {
   813   if (SYMBOL_WITH_POS_P (arg))
   814     return (SYMBOL_WITH_POS_SYM (arg));
   815   return arg;
   816 }
   817 
   818 DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0,
   819        doc: /* Create a new symbol with position.
   820 SYM is a symbol, with or without position, the symbol to position.
   821 POS, the position, is either a fixnum or a symbol with position from which
   822 the position will be taken.  */)
   823      (register Lisp_Object sym, register Lisp_Object pos)
   824 {
   825   Lisp_Object bare;
   826   Lisp_Object position;
   827 
   828   if (BARE_SYMBOL_P (sym))
   829     bare = sym;
   830   else if (SYMBOL_WITH_POS_P (sym))
   831     bare = XSYMBOL_WITH_POS (sym)->sym;
   832   else
   833     wrong_type_argument (Qsymbolp, sym);
   834 
   835   if (FIXNUMP (pos))
   836     position = pos;
   837   else if (SYMBOL_WITH_POS_P (pos))
   838     position = XSYMBOL_WITH_POS (pos)->pos;
   839   else
   840     wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos);
   841 
   842   return build_symbol_with_pos (bare, position);
   843 }
   844 
   845 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
   846        doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.  */)
   847   (register Lisp_Object symbol, Lisp_Object definition)
   848 {
   849   CHECK_SYMBOL (symbol);
   850   /* Perhaps not quite the right error signal, but seems good enough.  */
   851   if (NILP (symbol) && !NILP (definition))
   852     /* There are so many other ways to shoot oneself in the foot, I don't
   853        think this one little sanity check is worth its cost, but anyway.  */
   854     xsignal1 (Qsetting_constant, symbol);
   855 
   856   eassert (valid_lisp_object_p (definition));
   857 
   858 #ifdef HAVE_NATIVE_COMP
   859   register Lisp_Object function = XSYMBOL (symbol)->u.s.function;
   860 
   861   if (!NILP (Vnative_comp_enable_subr_trampolines)
   862       && SUBRP (function)
   863       && !SUBR_NATIVE_COMPILEDP (function))
   864     CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol);
   865 #endif
   866 
   867   set_symbol_function (symbol, definition);
   868 
   869   return definition;
   870 }
   871 
   872 static void
   873 add_to_function_history (Lisp_Object symbol, Lisp_Object olddef)
   874 {
   875   eassert (!NILP (olddef));
   876 
   877   Lisp_Object past = Fget (symbol, Qfunction_history);
   878   Lisp_Object file = Qnil;
   879   /* FIXME: Sadly, `Vload_file_name` gives less precise information
   880      (it's sometimes non-nil when it shoujld be nil).  */
   881   Lisp_Object tail = Vcurrent_load_list;
   882   FOR_EACH_TAIL_SAFE (tail)
   883     if (NILP (XCDR (tail)) && STRINGP (XCAR (tail)))
   884       file = XCAR (tail);
   885 
   886   Lisp_Object tem = plist_member (past, file);
   887   if (!NILP (tem))
   888     { /* New def from a file used before.
   889          Overwrite the previous record associated with this file.  */
   890       if (EQ (tem, past))
   891         /* The new def is from the same file as the last change, so
   892            there's nothing to do: unloading the file should revert to
   893            the status before the last change rather than before this load.  */
   894         return;
   895       Lisp_Object pastlen = Flength (past);
   896       Lisp_Object temlen = Flength (tem);
   897       EMACS_INT tempos = XFIXNUM (pastlen) - XFIXNUM (temlen);
   898       eassert (tempos > 1);
   899       Lisp_Object prev = Fnthcdr (make_fixnum (tempos - 2), past);
   900       /* Remove the previous info for this file.
   901          E.g. change `hist` from (... OTHERFILE DEF3 THISFILE DEF2 ...)
   902          to (... OTHERFILE DEF2). */
   903       XSETCDR (prev, XCDR (tem));
   904     }
   905   /* Push new def from new file.  */
   906   Fput (symbol, Qfunction_history, Fcons (file, Fcons (olddef, past)));
   907 }
   908 
   909 void
   910 defalias (Lisp_Object symbol, Lisp_Object definition)
   911 {
   912   {
   913     bool autoload = AUTOLOADP (definition);
   914     if (!will_dump_p () || !autoload)
   915       { /* Only add autoload entries after dumping, because the ones before are
   916            not useful and else we get loads of them from the loaddefs.el.
   917            That saves us about 110KB in the pdmp file (Jan 2022).  */
   918         LOADHIST_ATTACH (Fcons (Qdefun, symbol));
   919       }
   920   }
   921 
   922   {
   923     Lisp_Object olddef = XSYMBOL (symbol)->u.s.function;
   924     if (!NILP (olddef))
   925       {
   926         if (!NILP (Vautoload_queue))
   927           Vautoload_queue = Fcons (symbol, Vautoload_queue);
   928         add_to_function_history (symbol, olddef);
   929       }
   930   }
   931 
   932   { /* Handle automatic advice activation.  */
   933     Lisp_Object hook = Fget (symbol, Qdefalias_fset_function);
   934     if (!NILP (hook))
   935       call2 (hook, symbol, definition);
   936     else
   937       Ffset (symbol, definition);
   938   }
   939 }
   940 
   941 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
   942        doc: /* Set SYMBOL's function definition to DEFINITION.
   943 Associates the function with the current load file, if any.
   944 The optional third argument DOCSTRING specifies the documentation string
   945 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
   946 determined by DEFINITION.
   947 
   948 Internally, this normally uses `fset', but if SYMBOL has a
   949 `defalias-fset-function' property, the associated value is used instead.
   950 
   951 The return value is undefined.  */)
   952   (register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring)
   953 {
   954   CHECK_SYMBOL (symbol);
   955   if (!NILP (Vpurify_flag)
   956       /* If `definition' is a keymap, immutable (and copying) is wrong.  */
   957       && !KEYMAPP (definition))
   958     definition = Fpurecopy (definition);
   959 
   960   defalias (symbol, definition);
   961 
   962   maybe_defer_native_compilation (symbol, definition);
   963 
   964   if (!NILP (docstring))
   965     Fput (symbol, Qfunction_documentation, docstring);
   966   /* We used to return `definition', but now that `defun' and `defmacro' expand
   967      to a call to `defalias', we return `symbol' for backward compatibility
   968      (bug#11686).  */
   969   return symbol;
   970 }
   971 
   972 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
   973        doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.  */)
   974   (register Lisp_Object symbol, Lisp_Object newplist)
   975 {
   976   CHECK_SYMBOL (symbol);
   977   set_symbol_plist (symbol, newplist);
   978   return newplist;
   979 }
   980 
   981 DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
   982        doc: /* Return minimum and maximum number of args allowed for SUBR.
   983 SUBR must be a built-in function.
   984 The returned value is a pair (MIN . MAX).  MIN is the minimum number
   985 of args.  MAX is the maximum number or the symbol `many', for a
   986 function with `&rest' args, or `unevalled' for a special form.  */)
   987   (Lisp_Object subr)
   988 {
   989   short minargs, maxargs;
   990   CHECK_SUBR (subr);
   991   minargs = XSUBR (subr)->min_args;
   992   maxargs = XSUBR (subr)->max_args;
   993   return Fcons (make_fixnum (minargs),
   994                 maxargs == MANY ?        Qmany
   995                 : maxargs == UNEVALLED ? Qunevalled
   996                 :                        make_fixnum (maxargs));
   997 }
   998 
   999 DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
  1000        doc: /* Return name of subroutine SUBR.
  1001 SUBR must be a built-in function.  */)
  1002   (Lisp_Object subr)
  1003 {
  1004   const char *name;
  1005   CHECK_SUBR (subr);
  1006   name = XSUBR (subr)->symbol_name;
  1007   return build_string (name);
  1008 }
  1009 
  1010 DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1,
  1011        0, doc: /* Return t if the object is native compiled lisp
  1012 function, nil otherwise.  */)
  1013   (Lisp_Object object)
  1014 {
  1015   return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil;
  1016 }
  1017 
  1018 DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list,
  1019        Ssubr_native_lambda_list, 1, 1, 0,
  1020        doc: /* Return the lambda list for a native compiled lisp/d
  1021 function or t otherwise.  */)
  1022   (Lisp_Object subr)
  1023 {
  1024   CHECK_SUBR (subr);
  1025 
  1026 #ifdef HAVE_NATIVE_COMP
  1027   if (SUBR_NATIVE_COMPILED_DYNP (subr))
  1028     return XSUBR (subr)->lambda_list;
  1029 #endif
  1030   return Qt;
  1031 }
  1032 
  1033 DEFUN ("subr-type", Fsubr_type,
  1034        Ssubr_type, 1, 1, 0,
  1035        doc: /* Return the type of SUBR.  */)
  1036   (Lisp_Object subr)
  1037 {
  1038   CHECK_SUBR (subr);
  1039 #ifdef HAVE_NATIVE_COMP
  1040   return SUBR_TYPE (subr);
  1041 #else
  1042   return Qnil;
  1043 #endif
  1044 }
  1045 
  1046 #ifdef HAVE_NATIVE_COMP
  1047 
  1048 DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit,
  1049        Ssubr_native_comp_unit, 1, 1, 0,
  1050        doc: /* Return the native compilation unit.  */)
  1051   (Lisp_Object subr)
  1052 {
  1053   CHECK_SUBR (subr);
  1054   return XSUBR (subr)->native_comp_u;
  1055 }
  1056 
  1057 DEFUN ("native-comp-unit-file", Fnative_comp_unit_file,
  1058        Snative_comp_unit_file, 1, 1, 0,
  1059        doc: /* Return the file of the native compilation unit.  */)
  1060   (Lisp_Object comp_unit)
  1061 {
  1062   CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit);
  1063   return XNATIVE_COMP_UNIT (comp_unit)->file;
  1064 }
  1065 
  1066 DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file,
  1067        Snative_comp_unit_set_file, 2, 2, 0,
  1068        doc: /* Return the file of the native compilation unit.  */)
  1069   (Lisp_Object comp_unit, Lisp_Object new_file)
  1070 {
  1071   CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit);
  1072   XNATIVE_COMP_UNIT (comp_unit)->file = new_file;
  1073   return comp_unit;
  1074 }
  1075 
  1076 #endif
  1077 
  1078 DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
  1079        doc: /* Return the interactive form of CMD or nil if none.
  1080 If CMD is not a command, the return value is nil.
  1081 Value, if non-nil, is a list (interactive SPEC).  */)
  1082   (Lisp_Object cmd)
  1083 {
  1084   Lisp_Object fun = indirect_function (cmd); /* Check cycles.  */
  1085   bool genfun = false;
  1086 
  1087   if (NILP (fun))
  1088     return Qnil;
  1089 
  1090   /* Use an `interactive-form' property if present, analogous to the
  1091      function-documentation property.  */
  1092   fun = cmd;
  1093   while (SYMBOLP (fun))
  1094     {
  1095       Lisp_Object tmp = Fget (fun, Qinteractive_form);
  1096       if (!NILP (tmp))
  1097         return tmp;
  1098       else
  1099         fun = Fsymbol_function (fun);
  1100     }
  1101 
  1102   if (SUBRP (fun))
  1103     {
  1104       if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->intspec.native))
  1105         return XSUBR (fun)->intspec.native;
  1106 
  1107       const char *spec = XSUBR (fun)->intspec.string;
  1108       if (spec)
  1109         return list2 (Qinteractive,
  1110                       (*spec != '(') ? build_string (spec) :
  1111                       Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
  1112     }
  1113   else if (COMPILEDP (fun))
  1114     {
  1115       if (PVSIZE (fun) > COMPILED_INTERACTIVE)
  1116         {
  1117           Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE);
  1118           /* The vector form is the new form, where the first
  1119              element is the interactive spec, and the second is the
  1120              command modes. */
  1121           return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form);
  1122         }
  1123       else if (PVSIZE (fun) > COMPILED_DOC_STRING)
  1124         {
  1125           Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING);
  1126           /* An invalid "docstring" is a sign that we have an OClosure.  */
  1127           genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc));
  1128         }
  1129     }
  1130 #ifdef HAVE_MODULES
  1131   else if (MODULE_FUNCTIONP (fun))
  1132     {
  1133       Lisp_Object form
  1134         = module_function_interactive_form (XMODULE_FUNCTION (fun));
  1135       if (! NILP (form))
  1136         return form;
  1137     }
  1138 #endif
  1139   else if (AUTOLOADP (fun))
  1140     return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil));
  1141   else if (CONSP (fun))
  1142     {
  1143       Lisp_Object funcar = XCAR (fun);
  1144       if (EQ (funcar, Qclosure)
  1145           || EQ (funcar, Qlambda))
  1146         {
  1147           Lisp_Object form = Fcdr (XCDR (fun));
  1148           if (EQ (funcar, Qclosure))
  1149             form = Fcdr (form);
  1150           Lisp_Object spec = Fassq (Qinteractive, form);
  1151           if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form)))
  1152             /* A "docstring" is a sign that we may have an OClosure.  */
  1153             genfun = true;
  1154           else if (NILP (Fcdr (Fcdr (spec))))
  1155             return spec;
  1156           else
  1157             return list2 (Qinteractive, Fcar (Fcdr (spec)));
  1158         }
  1159     }
  1160   if (genfun
  1161       /* Avoid burping during bootstrap.  */
  1162       && !NILP (Fsymbol_function (Qoclosure_interactive_form)))
  1163     return call1 (Qoclosure_interactive_form, fun);
  1164   else
  1165     return Qnil;
  1166 }
  1167 
  1168 DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0,
  1169        doc: /* Return the modes COMMAND is defined for.
  1170 If COMMAND is not a command, the return value is nil.
  1171 The value, if non-nil, is a list of mode name symbols.  */)
  1172   (Lisp_Object command)
  1173 {
  1174   Lisp_Object fun = indirect_function (command); /* Check cycles.  */
  1175 
  1176   if (NILP (fun))
  1177     return Qnil;
  1178 
  1179   /* Use a `command-modes' property if present, analogous to the
  1180      function-documentation property.  */
  1181   fun = command;
  1182   while (SYMBOLP (fun))
  1183     {
  1184       Lisp_Object modes = Fget (fun, Qcommand_modes);
  1185       if (!NILP (modes))
  1186         return modes;
  1187       else
  1188         fun = Fsymbol_function (fun);
  1189     }
  1190 
  1191   if (SUBRP (fun))
  1192     {
  1193       return XSUBR (fun)->command_modes;
  1194     }
  1195   else if (COMPILEDP (fun))
  1196     {
  1197       if (PVSIZE (fun) <= COMPILED_INTERACTIVE)
  1198         return Qnil;
  1199       Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE);
  1200       if (VECTORP (form))
  1201         /* New form -- the second element is the command modes. */
  1202         return AREF (form, 1);
  1203       else
  1204         /* Old .elc file -- no command modes. */
  1205         return Qnil;
  1206     }
  1207 #ifdef HAVE_MODULES
  1208   else if (MODULE_FUNCTIONP (fun))
  1209     {
  1210       Lisp_Object form
  1211         = module_function_command_modes (XMODULE_FUNCTION (fun));
  1212       if (! NILP (form))
  1213         return form;
  1214     }
  1215 #endif
  1216   else if (AUTOLOADP (fun))
  1217     {
  1218       Lisp_Object modes = Fnth (make_int (3), fun);
  1219       if (CONSP (modes))
  1220         return modes;
  1221       else
  1222         return Qnil;
  1223     }
  1224   else if (CONSP (fun))
  1225     {
  1226       Lisp_Object funcar = XCAR (fun);
  1227       if (EQ (funcar, Qclosure)
  1228           || EQ (funcar, Qlambda))
  1229         {
  1230           Lisp_Object form = Fcdr (XCDR (fun));
  1231           if (EQ (funcar, Qclosure))
  1232             form = Fcdr (form);
  1233           return Fcdr (Fcdr (Fassq (Qinteractive, form)));
  1234         }
  1235     }
  1236   return Qnil;
  1237 }
  1238 
  1239 
  1240 /***********************************************************************
  1241                 Getting and Setting Values of Symbols
  1242  ***********************************************************************/
  1243 
  1244 /* Return the symbol holding SYMBOL's value.  Signal
  1245    `cyclic-variable-indirection' if SYMBOL's chain of variable
  1246    indirections contains a loop.  */
  1247 
  1248 struct Lisp_Symbol *
  1249 indirect_variable (struct Lisp_Symbol *symbol)
  1250 {
  1251   struct Lisp_Symbol *tortoise, *hare;
  1252 
  1253   hare = tortoise = symbol;
  1254 
  1255   while (hare->u.s.redirect == SYMBOL_VARALIAS)
  1256     {
  1257       hare = SYMBOL_ALIAS (hare);
  1258       if (hare->u.s.redirect != SYMBOL_VARALIAS)
  1259         break;
  1260 
  1261       hare = SYMBOL_ALIAS (hare);
  1262       tortoise = SYMBOL_ALIAS (tortoise);
  1263 
  1264       if (hare == tortoise)
  1265         {
  1266           Lisp_Object tem;
  1267           XSETSYMBOL (tem, symbol);
  1268           xsignal1 (Qcyclic_variable_indirection, tem);
  1269         }
  1270     }
  1271 
  1272   return hare;
  1273 }
  1274 
  1275 
  1276 DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
  1277        doc: /* Return the variable at the end of OBJECT's variable chain.
  1278 If OBJECT is a symbol, follow its variable indirections (if any), and
  1279 return the variable at the end of the chain of aliases.  See Info node
  1280 `(elisp)Variable Aliases'.
  1281 
  1282 If OBJECT is not a symbol, just return it.  If there is a loop in the
  1283 chain of aliases, signal a `cyclic-variable-indirection' error.  */)
  1284   (Lisp_Object object)
  1285 {
  1286   if (SYMBOLP (object))
  1287     {
  1288       struct Lisp_Symbol *sym = indirect_variable (XSYMBOL (object));
  1289       XSETSYMBOL (object, sym);
  1290     }
  1291   return object;
  1292 }
  1293 
  1294 
  1295 /* Given the raw contents of a symbol value cell,
  1296    return the Lisp value of the symbol.
  1297    This does not handle buffer-local variables; use
  1298    swap_in_symval_forwarding for that.  */
  1299 
  1300 Lisp_Object
  1301 do_symval_forwarding (lispfwd valcontents)
  1302 {
  1303   switch (XFWDTYPE (valcontents))
  1304     {
  1305     case Lisp_Fwd_Int:
  1306       return make_int (*XFIXNUMFWD (valcontents)->intvar);
  1307 
  1308     case Lisp_Fwd_Bool:
  1309       return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
  1310 
  1311     case Lisp_Fwd_Obj:
  1312       return *XOBJFWD (valcontents)->objvar;
  1313 
  1314     case Lisp_Fwd_Buffer_Obj:
  1315       return per_buffer_value (current_buffer,
  1316                                XBUFFER_OBJFWD (valcontents)->offset);
  1317 
  1318     case Lisp_Fwd_Kboard_Obj:
  1319       /* We used to simply use current_kboard here, but from Lisp
  1320          code, its value is often unexpected.  It seems nicer to
  1321          allow constructions like this to work as intuitively expected:
  1322 
  1323          (with-selected-frame frame
  1324          (define-key local-function-map "\eOP" [f1]))
  1325 
  1326          On the other hand, this affects the semantics of
  1327          last-command and real-last-command, and people may rely on
  1328          that.  I took a quick look at the Lisp codebase, and I
  1329          don't think anything will break.  --lorentey  */
  1330       return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
  1331                               + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
  1332     default: emacs_abort ();
  1333     }
  1334 }
  1335 
  1336 /* Used to signal a user-friendly error when symbol WRONG is
  1337    not a member of CHOICE, which should be a list of symbols.  */
  1338 
  1339 void
  1340 wrong_choice (Lisp_Object choice, Lisp_Object wrong)
  1341 {
  1342   ptrdiff_t i = 0, len = list_length (choice);
  1343   Lisp_Object obj, *args;
  1344   AUTO_STRING (one_of, "One of ");
  1345   AUTO_STRING (comma, ", ");
  1346   AUTO_STRING (or, " or ");
  1347   AUTO_STRING (should_be_specified, " should be specified");
  1348 
  1349   USE_SAFE_ALLOCA;
  1350   SAFE_ALLOCA_LISP (args, len * 2 + 1);
  1351 
  1352   args[i++] = one_of;
  1353 
  1354   for (obj = choice; !NILP (obj); obj = XCDR (obj))
  1355     {
  1356       args[i++] = SYMBOL_NAME (XCAR (obj));
  1357       args[i++] = (NILP (XCDR (obj)) ? should_be_specified
  1358                    : NILP (XCDR (XCDR (obj))) ? or : comma);
  1359     }
  1360 
  1361   obj = Fconcat (i, args);
  1362 
  1363   /* No need to call SAFE_FREE, since signaling does that for us.  */
  1364   (void) sa_count;
  1365 
  1366   xsignal2 (Qerror, obj, wrong);
  1367 }
  1368 
  1369 /* Used to signal a user-friendly error if WRONG is not a number or
  1370    integer/floating-point number outsize of inclusive MIN..MAX range.  */
  1371 
  1372 static void
  1373 wrong_range (Lisp_Object min, Lisp_Object max, Lisp_Object wrong)
  1374 {
  1375   AUTO_STRING (value_should_be_from, "Value should be from ");
  1376   AUTO_STRING (to, " to ");
  1377   xsignal2 (Qerror,
  1378             CALLN (Fconcat, value_should_be_from, Fnumber_to_string (min),
  1379                    to, Fnumber_to_string (max)),
  1380             wrong);
  1381 }
  1382 
  1383 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
  1384    of SYMBOL.  If SYMBOL is buffer-local, VALCONTENTS should be the
  1385    buffer-independent contents of the value cell: forwarded just one
  1386    step past the buffer-localness.
  1387 
  1388    BUF non-zero means set the value in buffer BUF instead of the
  1389    current buffer.  This only plays a role for per-buffer variables.  */
  1390 
  1391 static void
  1392 store_symval_forwarding (lispfwd valcontents, Lisp_Object newval,
  1393                          struct buffer *buf)
  1394 {
  1395   switch (XFWDTYPE (valcontents))
  1396     {
  1397     case Lisp_Fwd_Int:
  1398       {
  1399         intmax_t i;
  1400         CHECK_INTEGER (newval);
  1401         if (! integer_to_intmax (newval, &i))
  1402           xsignal1 (Qoverflow_error, newval);
  1403         *XFIXNUMFWD (valcontents)->intvar = i;
  1404       }
  1405       break;
  1406 
  1407     case Lisp_Fwd_Bool:
  1408       *XBOOLFWD (valcontents)->boolvar = !NILP (newval);
  1409       break;
  1410 
  1411     case Lisp_Fwd_Obj:
  1412       *XOBJFWD (valcontents)->objvar = newval;
  1413 
  1414       /* If this variable is a default for something stored
  1415          in the buffer itself, such as default-fill-column,
  1416          find the buffers that don't have local values for it
  1417          and update them.  */
  1418       if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults
  1419           && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1))
  1420         {
  1421           int offset = ((char *) XOBJFWD (valcontents)->objvar
  1422                         - (char *) &buffer_defaults);
  1423           int idx = PER_BUFFER_IDX (offset);
  1424 
  1425           Lisp_Object tail, buf;
  1426 
  1427           if (idx <= 0)
  1428             break;
  1429 
  1430           FOR_EACH_LIVE_BUFFER (tail, buf)
  1431             {
  1432               struct buffer *b = XBUFFER (buf);
  1433 
  1434               if (! PER_BUFFER_VALUE_P (b, idx))
  1435                 set_per_buffer_value (b, offset, newval);
  1436             }
  1437         }
  1438       break;
  1439 
  1440     case Lisp_Fwd_Buffer_Obj:
  1441       {
  1442         int offset = XBUFFER_OBJFWD (valcontents)->offset;
  1443         Lisp_Object predicate = XBUFFER_OBJFWD (valcontents)->predicate;
  1444 
  1445         if (!NILP (newval) && !NILP (predicate))
  1446           {
  1447             eassert (SYMBOLP (predicate));
  1448             Lisp_Object choiceprop = Fget (predicate, Qchoice);
  1449             if (!NILP (choiceprop))
  1450               {
  1451                 if (NILP (Fmemq (newval, choiceprop)))
  1452                   wrong_choice (choiceprop, newval);
  1453               }
  1454             else
  1455               {
  1456                 Lisp_Object rangeprop = Fget (predicate, Qrange);
  1457                 if (CONSP (rangeprop))
  1458                   {
  1459                     Lisp_Object min = XCAR (rangeprop), max = XCDR (rangeprop);
  1460                     if (! NUMBERP (newval)
  1461                         || NILP (CALLN (Fleq, min, newval, max)))
  1462                       wrong_range (min, max, newval);
  1463                   }
  1464                 else if (FUNCTIONP (predicate))
  1465                   {
  1466                     if (NILP (call1 (predicate, newval)))
  1467                       wrong_type_argument (predicate, newval);
  1468                   }
  1469               }
  1470           }
  1471         if (buf == NULL)
  1472           buf = current_buffer;
  1473         set_per_buffer_value (buf, offset, newval);
  1474       }
  1475       break;
  1476 
  1477     case Lisp_Fwd_Kboard_Obj:
  1478       {
  1479         char *base = (char *) FRAME_KBOARD (SELECTED_FRAME ());
  1480         char *p = base + XKBOARD_OBJFWD (valcontents)->offset;
  1481         *(Lisp_Object *) p = newval;
  1482       }
  1483       break;
  1484 
  1485     default:
  1486       emacs_abort (); /* goto def; */
  1487     }
  1488 }
  1489 
  1490 /* Set up SYMBOL to refer to its global binding.  This makes it safe
  1491    to alter the status of other bindings.  BEWARE: this may be called
  1492    during the mark phase of GC, where we assume that Lisp_Object slots
  1493    of BLV are marked after this function has changed them.  */
  1494 
  1495 void
  1496 swap_in_global_binding (struct Lisp_Symbol *symbol)
  1497 {
  1498   struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
  1499 
  1500   /* Unload the previously loaded binding.  */
  1501   if (blv->fwd.fwdptr)
  1502     set_blv_value (blv, do_symval_forwarding (blv->fwd));
  1503 
  1504   /* Select the global binding in the symbol.  */
  1505   set_blv_valcell (blv, blv->defcell);
  1506   if (blv->fwd.fwdptr)
  1507     store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL);
  1508 
  1509   /* Indicate that the global binding is set up now.  */
  1510   set_blv_where (blv, Qnil);
  1511   set_blv_found (blv, false);
  1512 }
  1513 
  1514 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
  1515    VALCONTENTS is the contents of its value cell,
  1516    which points to a struct Lisp_Buffer_Local_Value.
  1517 
  1518    Return the value forwarded one step past the buffer-local stage.
  1519    This could be another forwarding pointer.  */
  1520 
  1521 static void
  1522 swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_Value *blv)
  1523 {
  1524   register Lisp_Object tem1;
  1525 
  1526   eassert (blv == SYMBOL_BLV (symbol));
  1527 
  1528   tem1 = blv->where;
  1529 
  1530   if (NILP (tem1)
  1531       || current_buffer != XBUFFER (tem1))
  1532     {
  1533 
  1534       /* Unload the previously loaded binding.  */
  1535       tem1 = blv->valcell;
  1536       if (blv->fwd.fwdptr)
  1537         set_blv_value (blv, do_symval_forwarding (blv->fwd));
  1538       /* Choose the new binding.  */
  1539       {
  1540         Lisp_Object var;
  1541         XSETSYMBOL (var, symbol);
  1542         tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
  1543         set_blv_where (blv, Fcurrent_buffer ());
  1544       }
  1545       if (!(blv->found = !NILP (tem1)))
  1546         tem1 = blv->defcell;
  1547 
  1548       /* Load the new binding.  */
  1549       set_blv_valcell (blv, tem1);
  1550       if (blv->fwd.fwdptr)
  1551         store_symval_forwarding (blv->fwd, blv_value (blv), NULL);
  1552     }
  1553 }
  1554 
  1555 /* Find the value of a symbol, returning Qunbound if it's not bound.
  1556    This is helpful for code which just wants to get a variable's value
  1557    if it has one, without signaling an error.
  1558 
  1559    This function is very similar to buffer_local_value, but we have
  1560    two separate code paths here since find_symbol_value has to be very
  1561    efficient, while buffer_local_value doesn't have to be.
  1562 
  1563    Note that it must not be possible to quit within this function.
  1564    Great care is required for this.  */
  1565 
  1566 Lisp_Object
  1567 find_symbol_value (Lisp_Object symbol)
  1568 {
  1569   struct Lisp_Symbol *sym;
  1570 
  1571   CHECK_SYMBOL (symbol);
  1572   sym = XSYMBOL (symbol);
  1573 
  1574  start:
  1575   switch (sym->u.s.redirect)
  1576     {
  1577     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  1578     case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
  1579     case SYMBOL_LOCALIZED:
  1580       {
  1581         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  1582         swap_in_symval_forwarding (sym, blv);
  1583         return (blv->fwd.fwdptr
  1584                 ? do_symval_forwarding (blv->fwd)
  1585                 : blv_value (blv));
  1586       }
  1587     case SYMBOL_FORWARDED:
  1588       return do_symval_forwarding (SYMBOL_FWD (sym));
  1589     default: emacs_abort ();
  1590     }
  1591 }
  1592 
  1593 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
  1594        doc: /* Return SYMBOL's value.  Error if that is void.
  1595 Note that if `lexical-binding' is in effect, this returns the
  1596 global value outside of any lexical scope.  */)
  1597   (Lisp_Object symbol)
  1598 {
  1599   Lisp_Object val;
  1600 
  1601   val = find_symbol_value (symbol);
  1602   if (!BASE_EQ (val, Qunbound))
  1603     return val;
  1604 
  1605   xsignal1 (Qvoid_variable, symbol);
  1606 }
  1607 
  1608 DEFUN ("set", Fset, Sset, 2, 2, 0,
  1609        doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL.  */)
  1610   (register Lisp_Object symbol, Lisp_Object newval)
  1611 {
  1612   set_internal (symbol, newval, Qnil, SET_INTERNAL_SET);
  1613   return newval;
  1614 }
  1615 
  1616 /* Store the value NEWVAL into SYMBOL.
  1617    If buffer-locality is an issue, WHERE specifies which context to use.
  1618    (nil stands for the current buffer/frame).
  1619 
  1620    If BINDFLAG is SET_INTERNAL_SET, then if this symbol is supposed to
  1621    become local in every buffer where it is set, then we make it
  1622    local.  If BINDFLAG is SET_INTERNAL_BIND or SET_INTERNAL_UNBIND, we
  1623    don't do that.  */
  1624 
  1625 void
  1626 set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
  1627               enum Set_Internal_Bind bindflag)
  1628 {
  1629   bool voide = BASE_EQ (newval, Qunbound);
  1630 
  1631   /* If restoring in a dead buffer, do nothing.  */
  1632   /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
  1633       return; */
  1634 
  1635   CHECK_SYMBOL (symbol);
  1636   struct Lisp_Symbol *sym = XSYMBOL (symbol);
  1637   switch (sym->u.s.trapped_write)
  1638     {
  1639     case SYMBOL_NOWRITE:
  1640       if (NILP (Fkeywordp (symbol))
  1641           || !EQ (newval, Fsymbol_value (symbol)))
  1642         xsignal1 (Qsetting_constant, symbol);
  1643       else
  1644         /* Allow setting keywords to their own value.  */
  1645         return;
  1646 
  1647     case SYMBOL_TRAPPED_WRITE:
  1648       /* Setting due to thread-switching doesn't count.  */
  1649       if (bindflag != SET_INTERNAL_THREAD_SWITCH)
  1650         notify_variable_watchers (symbol, voide? Qnil : newval,
  1651                                   (bindflag == SET_INTERNAL_BIND? Qlet :
  1652                                    bindflag == SET_INTERNAL_UNBIND? Qunlet :
  1653                                    voide? Qmakunbound : Qset),
  1654                                   where);
  1655       break;
  1656 
  1657     case SYMBOL_UNTRAPPED_WRITE:
  1658       break;
  1659 
  1660     default: emacs_abort ();
  1661     }
  1662 
  1663  start:
  1664   switch (sym->u.s.redirect)
  1665     {
  1666     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  1667     case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
  1668     case SYMBOL_LOCALIZED:
  1669       {
  1670         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  1671         if (NILP (where))
  1672           XSETBUFFER (where, current_buffer);
  1673 
  1674         /* If the current buffer is not the buffer whose binding is
  1675            loaded, or if it's a Lisp_Buffer_Local_Value and
  1676            the default binding is loaded, the loaded binding may be the
  1677            wrong one.  */
  1678         if (!EQ (blv->where, where)
  1679             /* Also unload a global binding (if the var is local_if_set).  */
  1680             || (EQ (blv->valcell, blv->defcell)))
  1681           {
  1682             /* The currently loaded binding is not necessarily valid.
  1683                We need to unload it, and choose a new binding.  */
  1684 
  1685             /* Write out `realvalue' to the old loaded binding.  */
  1686             if (blv->fwd.fwdptr)
  1687               set_blv_value (blv, do_symval_forwarding (blv->fwd));
  1688 
  1689             /* Find the new binding.  */
  1690             XSETSYMBOL (symbol, sym); /* May have changed via aliasing.  */
  1691             Lisp_Object tem1
  1692               = assq_no_quit (symbol,
  1693                               BVAR (XBUFFER (where), local_var_alist));
  1694             set_blv_where (blv, where);
  1695             blv->found = true;
  1696 
  1697             if (NILP (tem1))
  1698               {
  1699                 /* This buffer still sees the default value.  */
  1700 
  1701                 /* If the variable is a Lisp_Some_Buffer_Local_Value,
  1702                    or if this is `let' rather than `set',
  1703                    make CURRENT-ALIST-ELEMENT point to itself,
  1704                    indicating that we're seeing the default value.
  1705                    Likewise if the variable has been let-bound
  1706                    in the current buffer.  */
  1707                 if (bindflag || !blv->local_if_set
  1708                     || let_shadows_buffer_binding_p (sym))
  1709                   {
  1710                     blv->found = false;
  1711                     tem1 = blv->defcell;
  1712                   }
  1713                 /* If it's a local_if_set, being set not bound,
  1714                    and we're not within a let that was made for this buffer,
  1715                    create a new buffer-local binding for the variable.
  1716                    That means, give this buffer a new assoc for a local value
  1717                    and load that binding.  */
  1718                 else
  1719                   {
  1720                     tem1 = Fcons (symbol, XCDR (blv->defcell));
  1721                     bset_local_var_alist
  1722                       (XBUFFER (where),
  1723                        Fcons (tem1, BVAR (XBUFFER (where), local_var_alist)));
  1724                   }
  1725               }
  1726 
  1727             /* Record which binding is now loaded.  */
  1728             set_blv_valcell (blv, tem1);
  1729           }
  1730 
  1731         /* Store the new value in the cons cell.  */
  1732         set_blv_value (blv, newval);
  1733 
  1734         if (blv->fwd.fwdptr)
  1735           {
  1736             if (voide)
  1737               /* If storing void (making the symbol void), forward only through
  1738                  buffer-local indicator, not through Lisp_Objfwd, etc.  */
  1739               blv->fwd.fwdptr = NULL;
  1740             else
  1741               store_symval_forwarding (blv->fwd, newval,
  1742                                        BUFFERP (where)
  1743                                        ? XBUFFER (where) : current_buffer);
  1744           }
  1745         break;
  1746       }
  1747     case SYMBOL_FORWARDED:
  1748       {
  1749         struct buffer *buf
  1750           = BUFFERP (where) ? XBUFFER (where) : current_buffer;
  1751         lispfwd innercontents = SYMBOL_FWD (sym);
  1752         if (BUFFER_OBJFWDP (innercontents))
  1753           {
  1754             int offset = XBUFFER_OBJFWD (innercontents)->offset;
  1755             int idx = PER_BUFFER_IDX (offset);
  1756             if (idx > 0 && bindflag == SET_INTERNAL_SET
  1757                 && !PER_BUFFER_VALUE_P (buf, idx))
  1758               {
  1759                 if (let_shadows_buffer_binding_p (sym))
  1760                   set_default_internal (symbol, newval, bindflag);
  1761                 else
  1762                   SET_PER_BUFFER_VALUE_P (buf, idx, 1);
  1763               }
  1764           }
  1765 
  1766         if (voide)
  1767           { /* If storing void (making the symbol void), forward only through
  1768                buffer-local indicator, not through Lisp_Objfwd, etc.  */
  1769             sym->u.s.redirect = SYMBOL_PLAINVAL;
  1770             SET_SYMBOL_VAL (sym, newval);
  1771           }
  1772         else
  1773           store_symval_forwarding (/* sym, */ innercontents, newval, buf);
  1774         break;
  1775       }
  1776     default: emacs_abort ();
  1777     }
  1778   return;
  1779 }
  1780 
  1781 static void
  1782 set_symbol_trapped_write (Lisp_Object symbol, enum symbol_trapped_write trap)
  1783 {
  1784   struct Lisp_Symbol *sym = XSYMBOL (symbol);
  1785   if (sym->u.s.trapped_write == SYMBOL_NOWRITE)
  1786     xsignal1 (Qtrapping_constant, symbol);
  1787   sym->u.s.trapped_write = trap;
  1788 }
  1789 
  1790 static void
  1791 restore_symbol_trapped_write (Lisp_Object symbol)
  1792 {
  1793   set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE);
  1794 }
  1795 
  1796 static void
  1797 harmonize_variable_watchers (Lisp_Object alias, Lisp_Object base_variable)
  1798 {
  1799   if (!EQ (base_variable, alias)
  1800       && EQ (base_variable, Findirect_variable (alias)))
  1801     set_symbol_trapped_write
  1802       (alias, XSYMBOL (base_variable)->u.s.trapped_write);
  1803 }
  1804 
  1805 DEFUN ("add-variable-watcher", Fadd_variable_watcher, Sadd_variable_watcher,
  1806        2, 2, 0,
  1807        doc: /* Cause WATCH-FUNCTION to be called when SYMBOL is about to be set.
  1808 
  1809 It will be called with 4 arguments: (SYMBOL NEWVAL OPERATION WHERE).
  1810 SYMBOL is the variable being changed.
  1811 NEWVAL is the value it will be changed to.  (The variable still has
  1812 the old value when WATCH-FUNCTION is called.)
  1813 OPERATION is a symbol representing the kind of change, one of: `set',
  1814 `let', `unlet', `makunbound', and `defvaralias'.
  1815 WHERE is a buffer if the buffer-local value of the variable is being
  1816 changed, nil otherwise.
  1817 
  1818 All writes to aliases of SYMBOL will call WATCH-FUNCTION too.  */)
  1819   (Lisp_Object symbol, Lisp_Object watch_function)
  1820 {
  1821   symbol = Findirect_variable (symbol);
  1822   CHECK_SYMBOL (symbol);
  1823   set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE);
  1824   map_obarray (Vobarray, harmonize_variable_watchers, symbol);
  1825 
  1826   Lisp_Object watchers = Fget (symbol, Qwatchers);
  1827   Lisp_Object member = Fmember (watch_function, watchers);
  1828   if (NILP (member))
  1829     Fput (symbol, Qwatchers, Fcons (watch_function, watchers));
  1830   return Qnil;
  1831 }
  1832 
  1833 DEFUN ("remove-variable-watcher", Fremove_variable_watcher, Sremove_variable_watcher,
  1834        2, 2, 0,
  1835        doc: /* Undo the effect of `add-variable-watcher'.
  1836 Remove WATCH-FUNCTION from the list of functions to be called when
  1837 SYMBOL (or its aliases) are set.  */)
  1838   (Lisp_Object symbol, Lisp_Object watch_function)
  1839 {
  1840   symbol = Findirect_variable (symbol);
  1841   Lisp_Object watchers = Fget (symbol, Qwatchers);
  1842   watchers = Fdelete (watch_function, watchers);
  1843   if (NILP (watchers))
  1844     {
  1845       set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE);
  1846       map_obarray (Vobarray, harmonize_variable_watchers, symbol);
  1847     }
  1848   Fput (symbol, Qwatchers, watchers);
  1849   return Qnil;
  1850 }
  1851 
  1852 DEFUN ("get-variable-watchers", Fget_variable_watchers, Sget_variable_watchers,
  1853        1, 1, 0,
  1854        doc: /* Return a list of SYMBOL's active watchers.  */)
  1855   (Lisp_Object symbol)
  1856 {
  1857   return (SYMBOL_TRAPPED_WRITE_P (symbol) == SYMBOL_TRAPPED_WRITE)
  1858     ? Fget (Findirect_variable (symbol), Qwatchers)
  1859     : Qnil;
  1860 }
  1861 
  1862 void
  1863 notify_variable_watchers (Lisp_Object symbol,
  1864                           Lisp_Object newval,
  1865                           Lisp_Object operation,
  1866                           Lisp_Object where)
  1867 {
  1868   symbol = Findirect_variable (symbol);
  1869 
  1870   specpdl_ref count = SPECPDL_INDEX ();
  1871   record_unwind_protect (restore_symbol_trapped_write, symbol);
  1872   /* Avoid recursion.  */
  1873   set_symbol_trapped_write (symbol, SYMBOL_UNTRAPPED_WRITE);
  1874 
  1875   if (NILP (where)
  1876       && !EQ (operation, Qset_default) && !EQ (operation, Qmakunbound)
  1877       && !NILP (Flocal_variable_if_set_p (symbol, Fcurrent_buffer ())))
  1878     {
  1879       XSETBUFFER (where, current_buffer);
  1880     }
  1881 
  1882   if (EQ (operation, Qset_default))
  1883     operation = Qset;
  1884 
  1885   for (Lisp_Object watchers = Fget (symbol, Qwatchers);
  1886        CONSP (watchers);
  1887        watchers = XCDR (watchers))
  1888     {
  1889       Lisp_Object watcher = XCAR (watchers);
  1890       /* Call subr directly to avoid gc.  */
  1891       if (SUBRP (watcher))
  1892         {
  1893           Lisp_Object args[] = { symbol, newval, operation, where };
  1894           funcall_subr (XSUBR (watcher), ARRAYELTS (args), args);
  1895         }
  1896       else
  1897         CALLN (Ffuncall, watcher, symbol, newval, operation, where);
  1898     }
  1899 
  1900   unbind_to (count, Qnil);
  1901 }
  1902 
  1903 
  1904 /* Access or set a buffer-local symbol's default value.  */
  1905 
  1906 /* Return the default value of SYMBOL, but don't check for voidness.
  1907    Return Qunbound if it is void.  */
  1908 
  1909 Lisp_Object
  1910 default_value (Lisp_Object symbol)
  1911 {
  1912   struct Lisp_Symbol *sym;
  1913 
  1914   CHECK_SYMBOL (symbol);
  1915   sym = XSYMBOL (symbol);
  1916 
  1917  start:
  1918   switch (sym->u.s.redirect)
  1919     {
  1920     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  1921     case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
  1922     case SYMBOL_LOCALIZED:
  1923       {
  1924         /* If var is set up for a buffer that lacks a local value for it,
  1925            the current value is nominally the default value.
  1926            But the `realvalue' slot may be more up to date, since
  1927            ordinary setq stores just that slot.  So use that.  */
  1928         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  1929         if (blv->fwd.fwdptr && EQ (blv->valcell, blv->defcell))
  1930           return do_symval_forwarding (blv->fwd);
  1931         else
  1932           return XCDR (blv->defcell);
  1933       }
  1934     case SYMBOL_FORWARDED:
  1935       {
  1936         lispfwd valcontents = SYMBOL_FWD (sym);
  1937 
  1938         /* For a built-in buffer-local variable, get the default value
  1939            rather than letting do_symval_forwarding get the current value.  */
  1940         if (BUFFER_OBJFWDP (valcontents))
  1941           {
  1942             int offset = XBUFFER_OBJFWD (valcontents)->offset;
  1943             if (PER_BUFFER_IDX (offset) != 0)
  1944               return per_buffer_default (offset);
  1945           }
  1946 
  1947         /* For other variables, get the current value.  */
  1948         return do_symval_forwarding (valcontents);
  1949       }
  1950     default: emacs_abort ();
  1951     }
  1952 }
  1953 
  1954 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
  1955        doc: /* Return t if SYMBOL has a non-void default value.
  1956 A variable may have a buffer-local value.  This function says whether
  1957 the variable has a non-void value outside of the current buffer
  1958 context.  Also see `default-value'.  */)
  1959   (Lisp_Object symbol)
  1960 {
  1961   register Lisp_Object value;
  1962 
  1963   value = default_value (symbol);
  1964   return (BASE_EQ (value, Qunbound) ? Qnil : Qt);
  1965 }
  1966 
  1967 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
  1968        doc: /* Return SYMBOL's default value.
  1969 This is the value that is seen in buffers that do not have their own values
  1970 for this variable.  The default value is meaningful for variables with
  1971 local bindings in certain buffers.  */)
  1972   (Lisp_Object symbol)
  1973 {
  1974   Lisp_Object value = default_value (symbol);
  1975   if (!BASE_EQ (value, Qunbound))
  1976     return value;
  1977 
  1978   xsignal1 (Qvoid_variable, symbol);
  1979 }
  1980 
  1981 void
  1982 set_default_internal (Lisp_Object symbol, Lisp_Object value,
  1983                       enum Set_Internal_Bind bindflag)
  1984 {
  1985   CHECK_SYMBOL (symbol);
  1986   struct Lisp_Symbol *sym = XSYMBOL (symbol);
  1987   switch (sym->u.s.trapped_write)
  1988     {
  1989     case SYMBOL_NOWRITE:
  1990       if (NILP (Fkeywordp (symbol))
  1991           || !EQ (value, Fsymbol_value (symbol)))
  1992         xsignal1 (Qsetting_constant, symbol);
  1993       else
  1994         /* Allow setting keywords to their own value.  */
  1995         return;
  1996 
  1997     case SYMBOL_TRAPPED_WRITE:
  1998       /* Don't notify here if we're going to call Fset anyway.  */
  1999       if (sym->u.s.redirect != SYMBOL_PLAINVAL
  2000           /* Setting due to thread switching doesn't count.  */
  2001           && bindflag != SET_INTERNAL_THREAD_SWITCH)
  2002         notify_variable_watchers (symbol, value, Qset_default, Qnil);
  2003       break;
  2004 
  2005     case SYMBOL_UNTRAPPED_WRITE:
  2006       break;
  2007 
  2008     default: emacs_abort ();
  2009     }
  2010 
  2011  start:
  2012   switch (sym->u.s.redirect)
  2013     {
  2014     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  2015     case SYMBOL_PLAINVAL: set_internal (symbol, value, Qnil, bindflag); return;
  2016     case SYMBOL_LOCALIZED:
  2017       {
  2018         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  2019 
  2020         /* Store new value into the DEFAULT-VALUE slot.  */
  2021         XSETCDR (blv->defcell, value);
  2022 
  2023         /* If the default binding is now loaded, set the REALVALUE slot too.  */
  2024         if (blv->fwd.fwdptr && EQ (blv->defcell, blv->valcell))
  2025           store_symval_forwarding (blv->fwd, value, NULL);
  2026         return;
  2027       }
  2028     case SYMBOL_FORWARDED:
  2029       {
  2030         lispfwd valcontents = SYMBOL_FWD (sym);
  2031 
  2032         /* Handle variables like case-fold-search that have special slots
  2033            in the buffer.
  2034            Make them work apparently like Lisp_Buffer_Local_Value variables.  */
  2035         if (BUFFER_OBJFWDP (valcontents))
  2036           {
  2037             int offset = XBUFFER_OBJFWD (valcontents)->offset;
  2038             int idx = PER_BUFFER_IDX (offset);
  2039 
  2040             set_per_buffer_default (offset, value);
  2041 
  2042             /* If this variable is not always local in all buffers,
  2043                set it in the buffers that don't nominally have a local value.  */
  2044             if (idx > 0)
  2045               {
  2046                 Lisp_Object buf, tail;
  2047 
  2048                 /* Do this only in live buffers, so that if there are
  2049                    a lot of buffers which are dead, that doesn't slow
  2050                    down let-binding of variables that are
  2051                    automatically local when set, like
  2052                    case-fold-search.  This is for Lisp programs that
  2053                    let-bind such variables in their inner loops.  */
  2054                 FOR_EACH_LIVE_BUFFER (tail, buf)
  2055                   {
  2056                     struct buffer *b = XBUFFER (buf);
  2057 
  2058                     if (!PER_BUFFER_VALUE_P (b, idx))
  2059                       set_per_buffer_value (b, offset, value);
  2060                   }
  2061               }
  2062           }
  2063         else
  2064           set_internal (symbol, value, Qnil, bindflag);
  2065         return;
  2066       }
  2067     default: emacs_abort ();
  2068     }
  2069 }
  2070 
  2071 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
  2072        doc: /* Set SYMBOL's default value to VALUE.  SYMBOL and VALUE are evaluated.
  2073 The default value is seen in buffers that do not have their own values
  2074 for this variable.  */)
  2075   (Lisp_Object symbol, Lisp_Object value)
  2076 {
  2077   set_default_internal (symbol, value, SET_INTERNAL_SET);
  2078   return value;
  2079 }
  2080 
  2081 /* Lisp functions for creating and removing buffer-local variables.  */
  2082 
  2083 union Lisp_Val_Fwd
  2084   {
  2085     Lisp_Object value;
  2086     lispfwd fwd;
  2087   };
  2088 
  2089 static struct Lisp_Buffer_Local_Value *
  2090 make_blv (struct Lisp_Symbol *sym, bool forwarded,
  2091           union Lisp_Val_Fwd valcontents)
  2092 {
  2093   struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
  2094   Lisp_Object symbol;
  2095   Lisp_Object tem;
  2096 
  2097  XSETSYMBOL (symbol, sym);
  2098  tem = Fcons (symbol, (forwarded
  2099                        ? do_symval_forwarding (valcontents.fwd)
  2100                        : valcontents.value));
  2101 
  2102   /* Buffer_Local_Values cannot have as realval a buffer-local
  2103      or keyboard-local forwarding.  */
  2104   eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd)));
  2105   eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
  2106   if (forwarded)
  2107     blv->fwd = valcontents.fwd;
  2108   else
  2109     blv->fwd.fwdptr = NULL;
  2110   set_blv_where (blv, Qnil);
  2111   blv->local_if_set = 0;
  2112   set_blv_defcell (blv, tem);
  2113   set_blv_valcell (blv, tem);
  2114   set_blv_found (blv, false);
  2115   __lsan_ignore_object (blv);
  2116   return blv;
  2117 }
  2118 
  2119 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local,
  2120        Smake_variable_buffer_local, 1, 1, "vMake Variable Buffer Local: ",
  2121        doc: /* Make VARIABLE become buffer-local whenever it is set.
  2122 At any time, the value for the current buffer is in effect,
  2123 unless the variable has never been set in this buffer,
  2124 in which case the default value is in effect.
  2125 Note that binding the variable with `let', or setting it while
  2126 a `let'-style binding made in this buffer is in effect,
  2127 does not make the variable buffer-local.  Return VARIABLE.
  2128 
  2129 This globally affects all uses of this variable, so it belongs together with
  2130 the variable declaration, rather than with its uses (if you just want to make
  2131 a variable local to the current buffer for one particular use, use
  2132 `make-local-variable').  Buffer-local bindings are normally cleared
  2133 while setting up a new major mode, unless they have a `permanent-local'
  2134 property.
  2135 
  2136 The function `default-value' gets the default value and `set-default' sets it.
  2137 
  2138 See also `defvar-local'.  */)
  2139   (register Lisp_Object variable)
  2140 {
  2141   struct Lisp_Symbol *sym;
  2142   struct Lisp_Buffer_Local_Value *blv = NULL;
  2143   union Lisp_Val_Fwd valcontents UNINIT;
  2144   bool forwarded UNINIT;
  2145 
  2146   CHECK_SYMBOL (variable);
  2147   sym = XSYMBOL (variable);
  2148 
  2149  start:
  2150   switch (sym->u.s.redirect)
  2151     {
  2152     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  2153     case SYMBOL_PLAINVAL:
  2154       forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
  2155       if (BASE_EQ (valcontents.value, Qunbound))
  2156         valcontents.value = Qnil;
  2157       break;
  2158     case SYMBOL_LOCALIZED:
  2159       blv = SYMBOL_BLV (sym);
  2160       break;
  2161     case SYMBOL_FORWARDED:
  2162       forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
  2163       if (KBOARD_OBJFWDP (valcontents.fwd))
  2164         error ("Symbol %s may not be buffer-local",
  2165                SDATA (SYMBOL_NAME (variable)));
  2166       else if (BUFFER_OBJFWDP (valcontents.fwd))
  2167         return variable;
  2168       break;
  2169     default: emacs_abort ();
  2170     }
  2171 
  2172   if (SYMBOL_CONSTANT_P (variable))
  2173     xsignal1 (Qsetting_constant, variable);
  2174 
  2175   if (!blv)
  2176     {
  2177       blv = make_blv (sym, forwarded, valcontents);
  2178       sym->u.s.redirect = SYMBOL_LOCALIZED;
  2179       SET_SYMBOL_BLV (sym, blv);
  2180     }
  2181 
  2182   blv->local_if_set = 1;
  2183   return variable;
  2184 }
  2185 
  2186 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
  2187        1, 1, "vMake Local Variable: ",
  2188        doc: /* Make VARIABLE have a separate value in the current buffer.
  2189 Other buffers will continue to share a common default value.
  2190 \(The buffer-local value of VARIABLE starts out as the same value
  2191 VARIABLE previously had.  If VARIABLE was void, it remains void.)
  2192 Return VARIABLE.
  2193 
  2194 If the variable is already arranged to become local when set,
  2195 this function causes a local value to exist for this buffer,
  2196 just as setting the variable would do.
  2197 
  2198 This function returns VARIABLE, and therefore
  2199   (set (make-local-variable \\='VARIABLE) VALUE-EXP)
  2200 works.
  2201 
  2202 See also `make-variable-buffer-local'.
  2203 
  2204 Do not use `make-local-variable' to make a hook variable buffer-local.
  2205 Instead, use `add-hook' and specify t for the LOCAL argument.  */)
  2206   (Lisp_Object variable)
  2207 {
  2208   Lisp_Object tem;
  2209   bool forwarded UNINIT;
  2210   union Lisp_Val_Fwd valcontents UNINIT;
  2211   struct Lisp_Symbol *sym;
  2212   struct Lisp_Buffer_Local_Value *blv = NULL;
  2213 
  2214   CHECK_SYMBOL (variable);
  2215   sym = XSYMBOL (variable);
  2216 
  2217  start:
  2218   switch (sym->u.s.redirect)
  2219     {
  2220     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  2221     case SYMBOL_PLAINVAL:
  2222       forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break;
  2223     case SYMBOL_LOCALIZED:
  2224       blv = SYMBOL_BLV (sym);
  2225       break;
  2226     case SYMBOL_FORWARDED:
  2227       forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
  2228       if (KBOARD_OBJFWDP (valcontents.fwd))
  2229         error ("Symbol %s may not be buffer-local",
  2230                SDATA (SYMBOL_NAME (variable)));
  2231       break;
  2232     default: emacs_abort ();
  2233     }
  2234 
  2235   if (sym->u.s.trapped_write == SYMBOL_NOWRITE)
  2236     xsignal1 (Qsetting_constant, variable);
  2237 
  2238   if (blv ? blv->local_if_set
  2239       : (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
  2240     {
  2241       tem = Fboundp (variable);
  2242       /* Make sure the symbol has a local value in this particular buffer,
  2243          by setting it to the same value it already has.  */
  2244       Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
  2245       return variable;
  2246     }
  2247   if (!blv)
  2248     {
  2249       blv = make_blv (sym, forwarded, valcontents);
  2250       sym->u.s.redirect = SYMBOL_LOCALIZED;
  2251       SET_SYMBOL_BLV (sym, blv);
  2252     }
  2253 
  2254   /* Make sure this buffer has its own value of symbol.  */
  2255   XSETSYMBOL (variable, sym);   /* Update in case of aliasing.  */
  2256   tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
  2257   if (NILP (tem))
  2258     {
  2259       if (let_shadows_buffer_binding_p (sym))
  2260         {
  2261           AUTO_STRING (format,
  2262                        "Making %s buffer-local while locally let-bound!");
  2263           CALLN (Fmessage, format, SYMBOL_NAME (variable));
  2264         }
  2265 
  2266       if (BUFFERP (blv->where) && current_buffer == XBUFFER (blv->where))
  2267         /* Make sure the current value is permanently recorded, if it's the
  2268            default value.  */
  2269         swap_in_global_binding (sym);
  2270 
  2271       bset_local_var_alist
  2272         (current_buffer,
  2273          Fcons (Fcons (variable, XCDR (blv->defcell)),
  2274                 BVAR (current_buffer, local_var_alist)));
  2275 
  2276       /* If the symbol forwards into a C variable, then load the binding
  2277          for this buffer now, to preserve the invariant that forwarded
  2278          variables must always hold the value corresponding to the
  2279          current buffer (they are swapped eagerly).
  2280          Otherwise, if C code modifies the variable before we load the
  2281          binding in, then that new value would clobber the default binding
  2282          the next time we unload it.  See bug#34318.  */
  2283       if (blv->fwd.fwdptr)
  2284         swap_in_symval_forwarding (sym, blv);
  2285     }
  2286 
  2287   return variable;
  2288 }
  2289 
  2290 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
  2291        1, 1, "vKill Local Variable: ",
  2292        doc: /* Make VARIABLE no longer have a separate value in the current buffer.
  2293 From now on the default value will apply in this buffer.  Return VARIABLE.  */)
  2294   (register Lisp_Object variable)
  2295 {
  2296   register Lisp_Object tem;
  2297   struct Lisp_Buffer_Local_Value *blv;
  2298   struct Lisp_Symbol *sym;
  2299 
  2300   CHECK_SYMBOL (variable);
  2301   sym = XSYMBOL (variable);
  2302 
  2303  start:
  2304   switch (sym->u.s.redirect)
  2305     {
  2306     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  2307     case SYMBOL_PLAINVAL: return variable;
  2308     case SYMBOL_FORWARDED:
  2309       {
  2310         lispfwd valcontents = SYMBOL_FWD (sym);
  2311         if (BUFFER_OBJFWDP (valcontents))
  2312           {
  2313             int offset = XBUFFER_OBJFWD (valcontents)->offset;
  2314             int idx = PER_BUFFER_IDX (offset);
  2315 
  2316             if (idx > 0)
  2317               {
  2318                 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
  2319                 set_per_buffer_value (current_buffer, offset,
  2320                                       per_buffer_default (offset));
  2321               }
  2322           }
  2323         return variable;
  2324       }
  2325     case SYMBOL_LOCALIZED:
  2326       blv = SYMBOL_BLV (sym);
  2327       break;
  2328     default: emacs_abort ();
  2329     }
  2330 
  2331   if (sym->u.s.trapped_write == SYMBOL_TRAPPED_WRITE)
  2332     notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ());
  2333 
  2334   /* Get rid of this buffer's alist element, if any.  */
  2335   XSETSYMBOL (variable, sym);   /* Propagate variable indirection.  */
  2336   tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
  2337   if (!NILP (tem))
  2338     bset_local_var_alist
  2339       (current_buffer,
  2340        Fdelq (tem, BVAR (current_buffer, local_var_alist)));
  2341 
  2342   /* If the symbol is set up with the current buffer's binding
  2343      loaded, recompute its value.  We have to do it now, or else
  2344      forwarded objects won't work right.  */
  2345   {
  2346     Lisp_Object buf; XSETBUFFER (buf, current_buffer);
  2347     if (BASE_EQ (buf, blv->where))
  2348       swap_in_global_binding (sym);
  2349   }
  2350 
  2351   return variable;
  2352 }
  2353 
  2354 /* Lisp functions for creating and removing buffer-local variables.  */
  2355 
  2356 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
  2357        1, 2, 0,
  2358        doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
  2359 BUFFER defaults to the current buffer.
  2360 
  2361 Also see `buffer-local-boundp'.*/)
  2362   (Lisp_Object variable, Lisp_Object buffer)
  2363 {
  2364   struct buffer *buf = decode_buffer (buffer);
  2365   struct Lisp_Symbol *sym;
  2366 
  2367   CHECK_SYMBOL (variable);
  2368   sym = XSYMBOL (variable);
  2369 
  2370  start:
  2371   switch (sym->u.s.redirect)
  2372     {
  2373     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  2374     case SYMBOL_PLAINVAL: return Qnil;
  2375     case SYMBOL_LOCALIZED:
  2376       {
  2377         Lisp_Object tmp;
  2378         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  2379         XSETBUFFER (tmp, buf);
  2380         XSETSYMBOL (variable, sym); /* Update in case of aliasing.  */
  2381 
  2382         if (EQ (blv->where, tmp)) /* The binding is already loaded.  */
  2383           return blv_found (blv) ? Qt : Qnil;
  2384         else
  2385           return NILP (assq_no_quit (variable, BVAR (buf, local_var_alist)))
  2386             ? Qnil
  2387             : Qt;
  2388       }
  2389     case SYMBOL_FORWARDED:
  2390       {
  2391         lispfwd valcontents = SYMBOL_FWD (sym);
  2392         if (BUFFER_OBJFWDP (valcontents))
  2393           {
  2394             int offset = XBUFFER_OBJFWD (valcontents)->offset;
  2395             int idx = PER_BUFFER_IDX (offset);
  2396             if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
  2397               return Qt;
  2398           }
  2399         return Qnil;
  2400       }
  2401     default: emacs_abort ();
  2402     }
  2403 }
  2404 
  2405 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
  2406        1, 2, 0,
  2407        doc: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
  2408 BUFFER defaults to the current buffer.
  2409 
  2410 More precisely, return non-nil if either VARIABLE already has a local
  2411 value in BUFFER, or if VARIABLE is automatically buffer-local (see
  2412 `make-variable-buffer-local').  */)
  2413   (register Lisp_Object variable, Lisp_Object buffer)
  2414 {
  2415   struct Lisp_Symbol *sym;
  2416 
  2417   CHECK_SYMBOL (variable);
  2418   sym = XSYMBOL (variable);
  2419 
  2420  start:
  2421   switch (sym->u.s.redirect)
  2422     {
  2423     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  2424     case SYMBOL_PLAINVAL: return Qnil;
  2425     case SYMBOL_LOCALIZED:
  2426       {
  2427         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  2428         if (blv->local_if_set)
  2429           return Qt;
  2430         XSETSYMBOL (variable, sym); /* Update in case of aliasing.  */
  2431         return Flocal_variable_p (variable, buffer);
  2432       }
  2433     case SYMBOL_FORWARDED:
  2434       /* All BUFFER_OBJFWD slots become local if they are set.  */
  2435       return (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) ? Qt : Qnil);
  2436     default: emacs_abort ();
  2437     }
  2438 }
  2439 
  2440 DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
  2441        1, 1, 0,
  2442        doc: /* Return a value indicating where VARIABLE's current binding comes from.
  2443 If the current binding is buffer-local, the value is the current buffer.
  2444 If the current binding is global (the default), the value is nil.  */)
  2445   (register Lisp_Object variable)
  2446 {
  2447   struct Lisp_Symbol *sym;
  2448 
  2449   CHECK_SYMBOL (variable);
  2450   sym = XSYMBOL (variable);
  2451 
  2452   /* Make sure the current binding is actually swapped in.  */
  2453   find_symbol_value (variable);
  2454 
  2455  start:
  2456   switch (sym->u.s.redirect)
  2457     {
  2458     case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
  2459     case SYMBOL_PLAINVAL: return Qnil;
  2460     case SYMBOL_FORWARDED:
  2461       {
  2462         lispfwd valcontents = SYMBOL_FWD (sym);
  2463         if (KBOARD_OBJFWDP (valcontents))
  2464           return Fframe_terminal (selected_frame);
  2465         else if (!BUFFER_OBJFWDP (valcontents))
  2466           return Qnil;
  2467       }
  2468       FALLTHROUGH;
  2469     case SYMBOL_LOCALIZED:
  2470       /* For a local variable, record both the symbol and which
  2471          buffer's or frame's value we are saving.  */
  2472       if (!NILP (Flocal_variable_p (variable, Qnil)))
  2473         return Fcurrent_buffer ();
  2474       else if (sym->u.s.redirect == SYMBOL_LOCALIZED
  2475                && blv_found (SYMBOL_BLV (sym)))
  2476         return SYMBOL_BLV (sym)->where;
  2477       else
  2478         return Qnil;
  2479     default: emacs_abort ();
  2480     }
  2481 }
  2482 
  2483 
  2484 /* Find the function at the end of a chain of symbol function indirections.  */
  2485 
  2486 /* If OBJECT is a symbol, find the end of its function chain and
  2487    return the value found there.  If OBJECT is not a symbol, just
  2488    return it.  If there is a cycle in the function chain, signal a
  2489    cyclic-function-indirection error.
  2490 
  2491    This is like Findirect_function, except that it doesn't signal an
  2492    error if the chain ends up unbound.  */
  2493 Lisp_Object
  2494 indirect_function (register Lisp_Object object)
  2495 {
  2496   Lisp_Object tortoise, hare;
  2497 
  2498   hare = tortoise = object;
  2499 
  2500   for (;;)
  2501     {
  2502       if (!SYMBOLP (hare) || NILP (hare))
  2503         break;
  2504       hare = XSYMBOL (hare)->u.s.function;
  2505       if (!SYMBOLP (hare) || NILP (hare))
  2506         break;
  2507       hare = XSYMBOL (hare)->u.s.function;
  2508 
  2509       tortoise = XSYMBOL (tortoise)->u.s.function;
  2510 
  2511       if (EQ (hare, tortoise))
  2512         xsignal1 (Qcyclic_function_indirection, object);
  2513     }
  2514 
  2515   return hare;
  2516 }
  2517 
  2518 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
  2519        doc: /* Return the function at the end of OBJECT's function chain.
  2520 If OBJECT is not a symbol, just return it.  Otherwise, follow all
  2521 function indirections to find the final function binding and return it.
  2522 Signal a cyclic-function-indirection error if there is a loop in the
  2523 function chain of symbols.  */)
  2524   (register Lisp_Object object, Lisp_Object noerror)
  2525 {
  2526   Lisp_Object result;
  2527 
  2528   /* Optimize for no indirection.  */
  2529   result = object;
  2530   if (SYMBOLP (result) && !NILP (result)
  2531       && (result = XSYMBOL (result)->u.s.function, SYMBOLP (result)))
  2532     result = indirect_function (result);
  2533   if (!NILP (result))
  2534     return result;
  2535 
  2536   return Qnil;
  2537 }
  2538 
  2539 /* Extract and set vector and string elements.  */
  2540 
  2541 DEFUN ("aref", Faref, Saref, 2, 2, 0,
  2542        doc: /* Return the element of ARRAY at index IDX.
  2543 ARRAY may be a vector, a string, a char-table, a bool-vector, a record,
  2544 or a byte-code object.  IDX starts at 0.  */)
  2545   (register Lisp_Object array, Lisp_Object idx)
  2546 {
  2547   register EMACS_INT idxval;
  2548 
  2549   CHECK_FIXNUM (idx);
  2550   idxval = XFIXNUM (idx);
  2551   if (STRINGP (array))
  2552     {
  2553       int c;
  2554       ptrdiff_t idxval_byte;
  2555 
  2556       if (idxval < 0 || idxval >= SCHARS (array))
  2557         args_out_of_range (array, idx);
  2558       if (! STRING_MULTIBYTE (array))
  2559         return make_fixnum ((unsigned char) SREF (array, idxval));
  2560       idxval_byte = string_char_to_byte (array, idxval);
  2561 
  2562       c = STRING_CHAR (SDATA (array) + idxval_byte);
  2563       return make_fixnum (c);
  2564     }
  2565   else if (BOOL_VECTOR_P (array))
  2566     {
  2567       if (idxval < 0 || idxval >= bool_vector_size (array))
  2568         args_out_of_range (array, idx);
  2569       return bool_vector_ref (array, idxval);
  2570     }
  2571   else if (CHAR_TABLE_P (array))
  2572     {
  2573       CHECK_CHARACTER (idx);
  2574       return CHAR_TABLE_REF (array, idxval);
  2575     }
  2576   else
  2577     {
  2578       ptrdiff_t size = 0;
  2579       if (VECTORP (array))
  2580         size = ASIZE (array);
  2581       else if (COMPILEDP (array) || RECORDP (array))
  2582         size = PVSIZE (array);
  2583       else
  2584         wrong_type_argument (Qarrayp, array);
  2585 
  2586       if (idxval < 0 || idxval >= size)
  2587         args_out_of_range (array, idx);
  2588       return AREF (array, idxval);
  2589     }
  2590 }
  2591 
  2592 DEFUN ("aset", Faset, Saset, 3, 3, 0,
  2593        doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
  2594 Return NEWELT.  ARRAY may be a vector, a string, a char-table or a
  2595 bool-vector.  IDX starts at 0.  */)
  2596   (register Lisp_Object array, Lisp_Object idx, Lisp_Object newelt)
  2597 {
  2598   register EMACS_INT idxval;
  2599 
  2600   CHECK_FIXNUM (idx);
  2601   idxval = XFIXNUM (idx);
  2602   if (! RECORDP (array))
  2603     CHECK_ARRAY (array, Qarrayp);
  2604 
  2605   if (VECTORP (array))
  2606     {
  2607       CHECK_IMPURE (array, XVECTOR (array));
  2608       if (idxval < 0 || idxval >= ASIZE (array))
  2609         args_out_of_range (array, idx);
  2610       ASET (array, idxval, newelt);
  2611     }
  2612   else if (BOOL_VECTOR_P (array))
  2613     {
  2614       if (idxval < 0 || idxval >= bool_vector_size (array))
  2615         args_out_of_range (array, idx);
  2616       bool_vector_set (array, idxval, !NILP (newelt));
  2617     }
  2618   else if (CHAR_TABLE_P (array))
  2619     {
  2620       CHECK_CHARACTER (idx);
  2621       CHAR_TABLE_SET (array, idxval, newelt);
  2622     }
  2623   else if (RECORDP (array))
  2624     {
  2625       if (idxval < 0 || idxval >= PVSIZE (array))
  2626         args_out_of_range (array, idx);
  2627       ASET (array, idxval, newelt);
  2628     }
  2629   else /* STRINGP */
  2630     {
  2631       CHECK_IMPURE (array, XSTRING (array));
  2632       if (idxval < 0 || idxval >= SCHARS (array))
  2633         args_out_of_range (array, idx);
  2634       CHECK_CHARACTER (newelt);
  2635       int c = XFIXNAT (newelt);
  2636       ptrdiff_t idxval_byte;
  2637       int prev_bytes;
  2638       unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
  2639 
  2640       if (STRING_MULTIBYTE (array))
  2641         {
  2642           idxval_byte = string_char_to_byte (array, idxval);
  2643           p1 = SDATA (array) + idxval_byte;
  2644           prev_bytes = BYTES_BY_CHAR_HEAD (*p1);
  2645         }
  2646       else if (SINGLE_BYTE_CHAR_P (c))
  2647         {
  2648           SSET (array, idxval, c);
  2649           return newelt;
  2650         }
  2651       else
  2652         {
  2653           for (ptrdiff_t i = SBYTES (array) - 1; i >= 0; i--)
  2654             if (!ASCII_CHAR_P (SREF (array, i)))
  2655               args_out_of_range (array, newelt);
  2656           /* ARRAY is an ASCII string.  Convert it to a multibyte string.  */
  2657           STRING_SET_MULTIBYTE (array);
  2658           idxval_byte = idxval;
  2659           p1 = SDATA (array) + idxval_byte;
  2660           prev_bytes = 1;
  2661         }
  2662 
  2663       int new_bytes = CHAR_STRING (c, p0);
  2664       if (prev_bytes != new_bytes)
  2665         p1 = resize_string_data (array, idxval_byte, prev_bytes, new_bytes);
  2666 
  2667       do
  2668         *p1++ = *p0++;
  2669       while (--new_bytes != 0);
  2670     }
  2671 
  2672   return newelt;
  2673 }
  2674 
  2675 /* Arithmetic functions */
  2676 
  2677 static Lisp_Object
  2678 check_integer_coerce_marker (Lisp_Object x)
  2679 {
  2680   if (MARKERP (x))
  2681     return make_fixnum (marker_position (x));
  2682   CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x);
  2683   return x;
  2684 }
  2685 
  2686 static Lisp_Object
  2687 check_number_coerce_marker (Lisp_Object x)
  2688 {
  2689   if (MARKERP (x))
  2690     return make_fixnum (marker_position (x));
  2691   CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x);
  2692   return x;
  2693 }
  2694 
  2695 Lisp_Object
  2696 arithcompare (Lisp_Object num1, Lisp_Object num2,
  2697               enum Arith_Comparison comparison)
  2698 {
  2699   EMACS_INT i1 = 0, i2 = 0;
  2700   bool lt, eq = true, gt;
  2701   bool test;
  2702 
  2703   num1 = check_number_coerce_marker (num1);
  2704   num2 = check_number_coerce_marker (num2);
  2705 
  2706   /* If the comparison is mostly done by comparing two doubles,
  2707      set LT, EQ, and GT to the <, ==, > results of that comparison,
  2708      respectively, taking care to avoid problems if either is a NaN,
  2709      and trying to avoid problems on platforms where variables (in
  2710      violation of the C standard) can contain excess precision.
  2711      Regardless, set I1 and I2 to integers that break ties if the
  2712      two-double comparison is either not done or reports
  2713      equality.  */
  2714 
  2715   if (FLOATP (num1))
  2716     {
  2717       double f1 = XFLOAT_DATA (num1);
  2718       if (FLOATP (num2))
  2719         {
  2720           double f2 = XFLOAT_DATA (num2);
  2721           lt = f1 < f2;
  2722           eq = f1 == f2;
  2723           gt = f1 > f2;
  2724         }
  2725       else if (FIXNUMP (num2))
  2726         {
  2727           /* Compare a float NUM1 to an integer NUM2 by converting the
  2728              integer I2 (i.e., NUM2) to the double F2 (a conversion that
  2729              can round on some platforms, if I2 is large enough), and then
  2730              converting F2 back to the integer I1 (a conversion that is
  2731              always exact), so that I1 exactly equals ((double) NUM2).  If
  2732              floating-point comparison reports a tie, NUM1 = F1 = F2 = I1
  2733              (exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1
  2734              to I2 will break the tie correctly.  */
  2735           double f2 = XFIXNUM (num2);
  2736           lt = f1 < f2;
  2737           eq = f1 == f2;
  2738           gt = f1 > f2;
  2739           i1 = f2;
  2740           i2 = XFIXNUM (num2);
  2741         }
  2742       else if (isnan (f1))
  2743         lt = eq = gt = false;
  2744       else
  2745         i2 = mpz_cmp_d (*xbignum_val (num2), f1);
  2746     }
  2747   else if (FIXNUMP (num1))
  2748     {
  2749       if (FLOATP (num2))
  2750         {
  2751           /* Compare an integer NUM1 to a float NUM2.  This is the
  2752              converse of comparing float to integer (see above).  */
  2753           double f1 = XFIXNUM (num1), f2 = XFLOAT_DATA (num2);
  2754           lt = f1 < f2;
  2755           eq = f1 == f2;
  2756           gt = f1 > f2;
  2757           i1 = XFIXNUM (num1);
  2758           i2 = f1;
  2759         }
  2760       else if (FIXNUMP (num2))
  2761         {
  2762           i1 = XFIXNUM (num1);
  2763           i2 = XFIXNUM (num2);
  2764         }
  2765       else
  2766         i2 = mpz_sgn (*xbignum_val (num2));
  2767     }
  2768   else if (FLOATP (num2))
  2769     {
  2770       double f2 = XFLOAT_DATA (num2);
  2771       if (isnan (f2))
  2772         lt = eq = gt = false;
  2773       else
  2774         i1 = mpz_cmp_d (*xbignum_val (num1), f2);
  2775     }
  2776   else if (FIXNUMP (num2))
  2777     i1 = mpz_sgn (*xbignum_val (num1));
  2778   else
  2779     i1 = mpz_cmp (*xbignum_val (num1), *xbignum_val (num2));
  2780 
  2781   if (eq)
  2782     {
  2783       /* The two-double comparison either reported equality, or was not done.
  2784          Break the tie by comparing the integers.  */
  2785       lt = i1 < i2;
  2786       eq = i1 == i2;
  2787       gt = i1 > i2;
  2788     }
  2789 
  2790   switch (comparison)
  2791     {
  2792     case ARITH_EQUAL:
  2793       test = eq;
  2794       break;
  2795 
  2796     case ARITH_NOTEQUAL:
  2797       test = !eq;
  2798       break;
  2799 
  2800     case ARITH_LESS:
  2801       test = lt;
  2802       break;
  2803 
  2804     case ARITH_LESS_OR_EQUAL:
  2805       test = lt | eq;
  2806       break;
  2807 
  2808     case ARITH_GRTR:
  2809       test = gt;
  2810       break;
  2811 
  2812     case ARITH_GRTR_OR_EQUAL:
  2813       test = gt | eq;
  2814       break;
  2815 
  2816     default:
  2817       eassume (false);
  2818     }
  2819 
  2820   return test ? Qt : Qnil;
  2821 }
  2822 
  2823 static Lisp_Object
  2824 arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
  2825                      enum Arith_Comparison comparison)
  2826 {
  2827   for (ptrdiff_t i = 1; i < nargs; i++)
  2828     if (NILP (arithcompare (args[i - 1], args[i], comparison)))
  2829       return Qnil;
  2830   return Qt;
  2831 }
  2832 
  2833 DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
  2834        doc: /* Return t if args, all numbers or markers, are equal.
  2835 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2836   (ptrdiff_t nargs, Lisp_Object *args)
  2837 {
  2838   return arithcompare_driver (nargs, args, ARITH_EQUAL);
  2839 }
  2840 
  2841 DEFUN ("<", Flss, Slss, 1, MANY, 0,
  2842        doc: /* Return t if each arg (a number or marker), is less than the next arg.
  2843 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2844   (ptrdiff_t nargs, Lisp_Object *args)
  2845 {
  2846   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2847     return XFIXNUM (args[0]) < XFIXNUM (args[1]) ? Qt : Qnil;
  2848 
  2849   return arithcompare_driver (nargs, args, ARITH_LESS);
  2850 }
  2851 
  2852 DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
  2853        doc: /* Return t if each arg (a number or marker) is greater than the next arg.
  2854 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2855   (ptrdiff_t nargs, Lisp_Object *args)
  2856 {
  2857   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2858     return XFIXNUM (args[0]) > XFIXNUM (args[1]) ? Qt : Qnil;
  2859 
  2860   return arithcompare_driver (nargs, args, ARITH_GRTR);
  2861 }
  2862 
  2863 DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
  2864        doc: /* Return t if each arg (a number or marker) is less than or equal to the next.
  2865 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2866   (ptrdiff_t nargs, Lisp_Object *args)
  2867 {
  2868   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2869     return XFIXNUM (args[0]) <= XFIXNUM (args[1]) ? Qt : Qnil;
  2870 
  2871   return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
  2872 }
  2873 
  2874 DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
  2875        doc: /* Return t if each arg (a number or marker) is greater than or equal to the next.
  2876 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2877   (ptrdiff_t nargs, Lisp_Object *args)
  2878 {
  2879   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2880     return XFIXNUM (args[0]) >= XFIXNUM (args[1]) ? Qt : Qnil;
  2881 
  2882   return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
  2883 }
  2884 
  2885 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
  2886        doc: /* Return t if first arg is not equal to second arg.  Both must be numbers or markers.  */)
  2887   (register Lisp_Object num1, Lisp_Object num2)
  2888 {
  2889   return arithcompare (num1, num2, ARITH_NOTEQUAL);
  2890 }
  2891 
  2892 /* Convert the cons-of-integers, integer, or float value C to an
  2893    unsigned value with maximum value MAX, where MAX is one less than a
  2894    power of 2.  Signal an error if C does not have a valid format or
  2895    is out of range.
  2896 
  2897    Although Emacs represents large integers with bignums instead of
  2898    cons-of-integers or floats, for now this function still accepts the
  2899    obsolete forms in case some old Lisp code still generates them.  */
  2900 uintmax_t
  2901 cons_to_unsigned (Lisp_Object c, uintmax_t max)
  2902 {
  2903   bool valid = false;
  2904   uintmax_t val UNINIT;
  2905 
  2906   if (FLOATP (c))
  2907     {
  2908       double d = XFLOAT_DATA (c);
  2909       if (d >= 0 && d < 1.0 + max)
  2910         {
  2911           val = d;
  2912           valid = val == d;
  2913         }
  2914     }
  2915   else
  2916     {
  2917       Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
  2918       valid = INTEGERP (hi) && integer_to_uintmax (hi, &val);
  2919 
  2920       if (valid && CONSP (c))
  2921         {
  2922           uintmax_t top = val;
  2923           Lisp_Object rest = XCDR (c);
  2924           if (top <= UINTMAX_MAX >> 24 >> 16
  2925               && CONSP (rest)
  2926               && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24
  2927               && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16)
  2928             {
  2929               uintmax_t mid = XFIXNAT (XCAR (rest));
  2930               val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest));
  2931             }
  2932           else
  2933             {
  2934               valid = top <= UINTMAX_MAX >> 16;
  2935               if (valid)
  2936                 {
  2937                   if (CONSP (rest))
  2938                     rest = XCAR (rest);
  2939                   valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16;
  2940                   if (valid)
  2941                     val = top << 16 | XFIXNAT (rest);
  2942                 }
  2943             }
  2944         }
  2945     }
  2946 
  2947   if (! (valid && val <= max))
  2948     error ("Not an in-range integer, integral float, or cons of integers");
  2949   return val;
  2950 }
  2951 
  2952 /* Convert the cons-of-integers, integer, or float value C to a signed
  2953    value with extrema MIN and MAX.  MAX should be one less than a
  2954    power of 2, and MIN should be zero or the negative of a power of 2.
  2955    Signal an error if C does not have a valid format or is out of
  2956    range.
  2957 
  2958    Although Emacs represents large integers with bignums instead of
  2959    cons-of-integers or floats, for now this function still accepts the
  2960    obsolete forms in case some old Lisp code still generates them.  */
  2961 intmax_t
  2962 cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
  2963 {
  2964   bool valid = false;
  2965   intmax_t val UNINIT;
  2966 
  2967   if (FLOATP (c))
  2968     {
  2969       double d = XFLOAT_DATA (c);
  2970       if (d >= min && d < 1.0 + max)
  2971         {
  2972           val = d;
  2973           valid = val == d;
  2974         }
  2975     }
  2976   else
  2977     {
  2978       Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
  2979       valid = INTEGERP (hi) && integer_to_intmax (hi, &val);
  2980 
  2981       if (valid && CONSP (c))
  2982         {
  2983           intmax_t top = val;
  2984           Lisp_Object rest = XCDR (c);
  2985           if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16
  2986               && CONSP (rest)
  2987               && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24
  2988               && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16)
  2989             {
  2990               intmax_t mid = XFIXNAT (XCAR (rest));
  2991               val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest));
  2992             }
  2993           else
  2994             {
  2995               valid = INTMAX_MIN >> 16 <= top && top <= INTMAX_MAX >> 16;
  2996               if (valid)
  2997                 {
  2998                   if (CONSP (rest))
  2999                     rest = XCAR (rest);
  3000                   valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16;
  3001                   if (valid)
  3002                     val = top << 16 | XFIXNAT (rest);
  3003                 }
  3004             }
  3005         }
  3006     }
  3007 
  3008   if (! (valid && min <= val && val <= max))
  3009     error ("Not an in-range integer, integral float, or cons of integers");
  3010   return val;
  3011 }
  3012 
  3013 /* Render NUMBER in decimal into BUFFER which ends right before END.
  3014    Return the start of the string; the end is always at END.
  3015    The string is not null-terminated.  */
  3016 char *
  3017 fixnum_to_string (EMACS_INT number, char *buffer, char *end)
  3018 {
  3019   EMACS_INT x = number;
  3020   bool negative = x < 0;
  3021   if (negative)
  3022     x = -x;
  3023   char *p = end;
  3024   do
  3025     {
  3026       eassume (p > buffer && p - 1 < end);
  3027       *--p = '0' + x % 10;
  3028       x /= 10;
  3029     }
  3030   while (x);
  3031   if (negative)
  3032     *--p = '-';
  3033   return p;
  3034 }
  3035 
  3036 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
  3037        doc: /* Return the decimal representation of NUMBER as a string.
  3038 Uses a minus sign if negative.
  3039 NUMBER may be an integer or a floating point number.  */)
  3040   (Lisp_Object number)
  3041 {
  3042   char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))];
  3043 
  3044   if (FIXNUMP (number))
  3045     {
  3046       char *end = buffer + sizeof buffer;
  3047       char *p = fixnum_to_string (XFIXNUM (number), buffer, end);
  3048       return make_unibyte_string (p, end - p);
  3049     }
  3050 
  3051   if (BIGNUMP (number))
  3052     return bignum_to_string (number, 10);
  3053 
  3054   if (FLOATP (number))
  3055     return make_unibyte_string (buffer,
  3056                                 float_to_string (buffer, XFLOAT_DATA (number)));
  3057 
  3058   wrong_type_argument (Qnumberp, number);
  3059 }
  3060 
  3061 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
  3062        doc: /* Parse STRING as a decimal number and return the number.
  3063 Ignore leading spaces and tabs, and all trailing chars.  Return 0 if
  3064 STRING cannot be parsed as an integer or floating point number.
  3065 
  3066 If BASE, interpret STRING as a number in that base.  If BASE isn't
  3067 present, base 10 is used.  BASE must be between 2 and 16 (inclusive).
  3068 If the base used is not 10, STRING is always parsed as an integer.  */)
  3069   (register Lisp_Object string, Lisp_Object base)
  3070 {
  3071   int b;
  3072 
  3073   CHECK_STRING (string);
  3074 
  3075   if (NILP (base))
  3076     b = 10;
  3077   else
  3078     {
  3079       CHECK_FIXNUM (base);
  3080       if (! (XFIXNUM (base) >= 2 && XFIXNUM (base) <= 16))
  3081         xsignal1 (Qargs_out_of_range, base);
  3082       b = XFIXNUM (base);
  3083     }
  3084 
  3085   char *p = SSDATA (string);
  3086   while (*p == ' ' || *p == '\t')
  3087     p++;
  3088 
  3089   Lisp_Object val = string_to_number (p, b, 0);
  3090   return NILP (val) ? make_fixnum (0) : val;
  3091 }
  3092 
  3093 enum arithop
  3094   {
  3095     Aadd,
  3096     Asub,
  3097     Amult,
  3098     Adiv,
  3099     Alogand,
  3100     Alogior,
  3101     Alogxor
  3102   };
  3103 static bool
  3104 floating_point_op (enum arithop code)
  3105 {
  3106   return code <= Adiv;
  3107 }
  3108 
  3109 /* Return the result of applying the floating-point operation CODE to
  3110    the NARGS arguments starting at ARGS.  If ARGNUM is positive,
  3111    ARGNUM of the arguments were already consumed, yielding ACCUM.
  3112    0 <= ARGNUM < NARGS, 2 <= NARGS, and NEXT is the value of
  3113    ARGS[ARGSNUM], converted to double.  */
  3114 
  3115 static Lisp_Object
  3116 floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3117                       ptrdiff_t argnum, double accum, double next)
  3118 {
  3119   if (argnum == 0)
  3120     {
  3121       accum = next;
  3122       goto next_arg;
  3123     }
  3124 
  3125   while (true)
  3126     {
  3127       switch (code)
  3128         {
  3129         case Aadd : accum += next; break;
  3130         case Asub : accum -= next; break;
  3131         case Amult: accum *= next; break;
  3132         case Adiv:
  3133           if (! IEEE_FLOATING_POINT && next == 0)
  3134             xsignal0 (Qarith_error);
  3135           accum /= next;
  3136           break;
  3137         default: eassume (false);
  3138         }
  3139 
  3140     next_arg:
  3141       argnum++;
  3142       if (argnum == nargs)
  3143         return make_float (accum);
  3144       next = XFLOATINT (check_number_coerce_marker (args[argnum]));
  3145     }
  3146 }
  3147 
  3148 /* Like floatop_arith_driver, except CODE might not be a floating-point
  3149    operation, and NEXT is a Lisp float rather than a C double.  */
  3150 
  3151 static Lisp_Object
  3152 float_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3153                     ptrdiff_t argnum, double accum, Lisp_Object next)
  3154 {
  3155   if (! floating_point_op (code))
  3156     wrong_type_argument (Qinteger_or_marker_p, next);
  3157   return floatop_arith_driver (code, nargs, args, argnum, accum,
  3158                                XFLOAT_DATA (next));
  3159 }
  3160 
  3161 /* Return the result of applying the arithmetic operation CODE to the
  3162    NARGS arguments starting at ARGS.  If ARGNUM is positive, ARGNUM of
  3163    the arguments were already consumed, yielding IACCUM.  0 <= ARGNUM
  3164    < NARGS, 2 <= NARGS, and VAL is the value of ARGS[ARGSNUM],
  3165    converted to integer.  */
  3166 
  3167 static Lisp_Object
  3168 bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3169                      ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val)
  3170 {
  3171   mpz_t const *accum;
  3172   if (argnum == 0)
  3173     {
  3174       accum = bignum_integer (&mpz[0], val);
  3175       goto next_arg;
  3176     }
  3177   mpz_set_intmax (mpz[0], iaccum);
  3178   accum = &mpz[0];
  3179 
  3180   while (true)
  3181     {
  3182       mpz_t const *next = bignum_integer (&mpz[1], val);
  3183 
  3184       switch (code)
  3185         {
  3186         case Aadd   :       mpz_add (mpz[0], *accum, *next); break;
  3187         case Asub   :       mpz_sub (mpz[0], *accum, *next); break;
  3188         case Amult  : emacs_mpz_mul (mpz[0], *accum, *next); break;
  3189         case Alogand:       mpz_and (mpz[0], *accum, *next); break;
  3190         case Alogior:       mpz_ior (mpz[0], *accum, *next); break;
  3191         case Alogxor:       mpz_xor (mpz[0], *accum, *next); break;
  3192         case Adiv:
  3193           if (mpz_sgn (*next) == 0)
  3194             xsignal0 (Qarith_error);
  3195           mpz_tdiv_q (mpz[0], *accum, *next);
  3196           break;
  3197         default:
  3198           eassume (false);
  3199         }
  3200       accum = &mpz[0];
  3201 
  3202     next_arg:
  3203       argnum++;
  3204       if (argnum == nargs)
  3205         return make_integer_mpz ();
  3206       val = check_number_coerce_marker (args[argnum]);
  3207       if (FLOATP (val))
  3208         return float_arith_driver (code, nargs, args, argnum,
  3209                                    mpz_get_d_rounded (*accum), val);
  3210     }
  3211 }
  3212 
  3213 /* Return the result of applying the arithmetic operation CODE to the
  3214    NARGS arguments starting at ARGS, with the first argument being the
  3215    number VAL.  2 <= NARGS.  Check that the remaining arguments are
  3216    numbers or markers.  */
  3217 
  3218 static Lisp_Object
  3219 arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3220               Lisp_Object val)
  3221 {
  3222   eassume (2 <= nargs);
  3223 
  3224   ptrdiff_t argnum = 0;
  3225   /* Set ACCUM to VAL's value if it is a fixnum, otherwise to some
  3226      ignored value to avoid using an uninitialized variable later.  */
  3227   intmax_t accum = XFIXNUM_RAW (val);
  3228 
  3229   if (FIXNUMP (val))
  3230     while (true)
  3231       {
  3232         argnum++;
  3233         if (argnum == nargs)
  3234           return make_int (accum);
  3235         val = check_number_coerce_marker (args[argnum]);
  3236 
  3237         /* Set NEXT to the next value if it fits, else exit the loop.  */
  3238         intmax_t next;
  3239         if (! (INTEGERP (val) && integer_to_intmax (val, &next)))
  3240           break;
  3241 
  3242         /* Set ACCUM to the next operation's result if it fits,
  3243            else exit the loop.  */
  3244         bool overflow;
  3245         intmax_t a;
  3246         switch (code)
  3247           {
  3248           case Aadd : overflow = INT_ADD_WRAPV (accum, next, &a); break;
  3249           case Amult: overflow = INT_MULTIPLY_WRAPV (accum, next, &a); break;
  3250           case Asub : overflow = INT_SUBTRACT_WRAPV (accum, next, &a); break;
  3251           case Adiv:
  3252             if (next == 0)
  3253               xsignal0 (Qarith_error);
  3254             /* This cannot overflow, as integer overflow can
  3255                occur only if the dividend is INTMAX_MIN, but
  3256                INTMAX_MIN < MOST_NEGATIVE_FIXNUM <= accum.  */
  3257             accum /= next;
  3258             continue;
  3259           case Alogand: accum &= next; continue;
  3260           case Alogior: accum |= next; continue;
  3261           case Alogxor: accum ^= next; continue;
  3262           default: eassume (false);
  3263           }
  3264         if (overflow)
  3265           break;
  3266         accum = a;
  3267       }
  3268 
  3269   return (FLOATP (val)
  3270           ? float_arith_driver (code, nargs, args, argnum, accum, val)
  3271           : bignum_arith_driver (code, nargs, args, argnum, accum, val));
  3272 }
  3273 
  3274 
  3275 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
  3276        doc: /* Return sum of any number of arguments, which are numbers or markers.
  3277 usage: (+ &rest NUMBERS-OR-MARKERS)  */)
  3278   (ptrdiff_t nargs, Lisp_Object *args)
  3279 {
  3280   if (nargs == 0)
  3281     return make_fixnum (0);
  3282   Lisp_Object a = check_number_coerce_marker (args[0]);
  3283   return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a);
  3284 }
  3285 
  3286 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
  3287        doc: /* Negate number or subtract numbers or markers and return the result.
  3288 With one arg, negates it.  With more than one arg,
  3289 subtracts all but the first from the first.
  3290 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS)  */)
  3291   (ptrdiff_t nargs, Lisp_Object *args)
  3292 {
  3293   if (nargs == 0)
  3294     return make_fixnum (0);
  3295   Lisp_Object a = check_number_coerce_marker (args[0]);
  3296   if (nargs == 1)
  3297     {
  3298       if (FIXNUMP (a))
  3299         return make_int (-XFIXNUM (a));
  3300       if (FLOATP (a))
  3301         return make_float (-XFLOAT_DATA (a));
  3302       mpz_neg (mpz[0], *xbignum_val (a));
  3303       return make_integer_mpz ();
  3304     }
  3305   return arith_driver (Asub, nargs, args, a);
  3306 }
  3307 
  3308 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
  3309        doc: /* Return product of any number of arguments, which are numbers or markers.
  3310 usage: (* &rest NUMBERS-OR-MARKERS)  */)
  3311   (ptrdiff_t nargs, Lisp_Object *args)
  3312 {
  3313   if (nargs == 0)
  3314     return make_fixnum (1);
  3315   Lisp_Object a = check_number_coerce_marker (args[0]);
  3316   return nargs == 1 ? a : arith_driver (Amult, nargs, args, a);
  3317 }
  3318 
  3319 DEFUN ("/", Fquo, Squo, 1, MANY, 0,
  3320        doc: /* Divide number by divisors and return the result.
  3321 With two or more arguments, return first argument divided by the rest.
  3322 With one argument, return 1 divided by the argument.
  3323 The arguments must be numbers or markers.
  3324 usage: (/ NUMBER &rest DIVISORS)  */)
  3325   (ptrdiff_t nargs, Lisp_Object *args)
  3326 {
  3327   Lisp_Object a = check_number_coerce_marker (args[0]);
  3328   if (nargs == 1)
  3329     {
  3330       if (FIXNUMP (a))
  3331         {
  3332           if (XFIXNUM (a) == 0)
  3333             xsignal0 (Qarith_error);
  3334           return make_fixnum (1 / XFIXNUM (a));
  3335         }
  3336       if (FLOATP (a))
  3337         {
  3338           if (! IEEE_FLOATING_POINT && XFLOAT_DATA (a) == 0)
  3339             xsignal0 (Qarith_error);
  3340           return make_float (1 / XFLOAT_DATA (a));
  3341         }
  3342       /* Dividing 1 by any bignum yields 0.  */
  3343       return make_fixnum (0);
  3344     }
  3345 
  3346   /* Do all computation in floating-point if any arg is a float.  */
  3347   for (ptrdiff_t argnum = 2; argnum < nargs; argnum++)
  3348     if (FLOATP (args[argnum]))
  3349       return floatop_arith_driver (Adiv, nargs, args, 0, 0, XFLOATINT (a));
  3350   return arith_driver (Adiv, nargs, args, a);
  3351 }
  3352 
  3353 /* Return NUM % DEN (or NUM mod DEN, if MODULO).  NUM and DEN must be
  3354    integers.  */
  3355 static Lisp_Object
  3356 integer_remainder (Lisp_Object num, Lisp_Object den, bool modulo)
  3357 {
  3358   if (FIXNUMP (den))
  3359     {
  3360       EMACS_INT d = XFIXNUM (den);
  3361       if (d == 0)
  3362         xsignal0 (Qarith_error);
  3363 
  3364       EMACS_INT r;
  3365       bool have_r = false;
  3366       if (FIXNUMP (num))
  3367         {
  3368           r = XFIXNUM (num) % d;
  3369           have_r = true;
  3370         }
  3371       else if (eabs (d) <= ULONG_MAX)
  3372         {
  3373           mpz_t const *n = xbignum_val (num);
  3374           bool neg_n = mpz_sgn (*n) < 0;
  3375           r = mpz_tdiv_ui (*n, eabs (d));
  3376           if (neg_n)
  3377             r = -r;
  3378           have_r = true;
  3379         }
  3380 
  3381       if (have_r)
  3382         {
  3383           /* If MODULO and the remainder has the wrong sign, fix it.  */
  3384           if (modulo && (d < 0 ? r > 0 : r < 0))
  3385             r += d;
  3386 
  3387           return make_fixnum (r);
  3388         }
  3389     }
  3390 
  3391   mpz_t const *d = bignum_integer (&mpz[1], den);
  3392   mpz_t *r = &mpz[0];
  3393   mpz_tdiv_r (*r, *bignum_integer (&mpz[0], num), *d);
  3394 
  3395   if (modulo)
  3396     {
  3397       /* If the remainder has the wrong sign, fix it.  */
  3398       int sgn_r = mpz_sgn (*r);
  3399       if (mpz_sgn (*d) < 0 ? sgn_r > 0 : sgn_r < 0)
  3400         mpz_add (*r, *r, *d);
  3401     }
  3402 
  3403   return make_integer_mpz ();
  3404 }
  3405 
  3406 DEFUN ("%", Frem, Srem, 2, 2, 0,
  3407        doc: /* Return remainder of X divided by Y.
  3408 Both must be integers or markers.  */)
  3409   (Lisp_Object x, Lisp_Object y)
  3410 {
  3411   x = check_integer_coerce_marker (x);
  3412   y = check_integer_coerce_marker (y);
  3413   return integer_remainder (x, y, false);
  3414 }
  3415 
  3416 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
  3417        doc: /* Return X modulo Y.
  3418 The result falls between zero (inclusive) and Y (exclusive).
  3419 Both X and Y must be numbers or markers.  */)
  3420   (Lisp_Object x, Lisp_Object y)
  3421 {
  3422   x = check_number_coerce_marker (x);
  3423   y = check_number_coerce_marker (y);
  3424   if (FLOATP (x) || FLOATP (y))
  3425     return fmod_float (x, y);
  3426   return integer_remainder (x, y, true);
  3427 }
  3428 
  3429 static Lisp_Object
  3430 minmax_driver (ptrdiff_t nargs, Lisp_Object *args,
  3431                enum Arith_Comparison comparison)
  3432 {
  3433   Lisp_Object accum = check_number_coerce_marker (args[0]);
  3434   for (ptrdiff_t argnum = 1; argnum < nargs; argnum++)
  3435     {
  3436       Lisp_Object val = check_number_coerce_marker (args[argnum]);
  3437       if (!NILP (arithcompare (val, accum, comparison)))
  3438         accum = val;
  3439       else if (FLOATP (val) && isnan (XFLOAT_DATA (val)))
  3440         return val;
  3441     }
  3442   return accum;
  3443 }
  3444 
  3445 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
  3446        doc: /* Return largest of all the arguments (which must be numbers or markers).
  3447 The value is always a number; markers are converted to numbers.
  3448 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  3449   (ptrdiff_t nargs, Lisp_Object *args)
  3450 {
  3451   return minmax_driver (nargs, args, ARITH_GRTR);
  3452 }
  3453 
  3454 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
  3455        doc: /* Return smallest of all the arguments (which must be numbers or markers).
  3456 The value is always a number; markers are converted to numbers.
  3457 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  3458   (ptrdiff_t nargs, Lisp_Object *args)
  3459 {
  3460   return minmax_driver (nargs, args, ARITH_LESS);
  3461 }
  3462 
  3463 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
  3464        doc: /* Return bitwise-and of all the arguments.
  3465 Arguments may be integers, or markers converted to integers.
  3466 usage: (logand &rest INTS-OR-MARKERS)  */)
  3467   (ptrdiff_t nargs, Lisp_Object *args)
  3468 {
  3469   if (nargs == 0)
  3470     return make_fixnum (-1);
  3471   Lisp_Object a = check_integer_coerce_marker (args[0]);
  3472   return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a);
  3473 }
  3474 
  3475 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
  3476        doc: /* Return bitwise-or of all the arguments.
  3477 Arguments may be integers, or markers converted to integers.
  3478 usage: (logior &rest INTS-OR-MARKERS)  */)
  3479   (ptrdiff_t nargs, Lisp_Object *args)
  3480 {
  3481   if (nargs == 0)
  3482     return make_fixnum (0);
  3483   Lisp_Object a = check_integer_coerce_marker (args[0]);
  3484   return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a);
  3485 }
  3486 
  3487 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
  3488        doc: /* Return bitwise-exclusive-or of all the arguments.
  3489 Arguments may be integers, or markers converted to integers.
  3490 usage: (logxor &rest INTS-OR-MARKERS)  */)
  3491   (ptrdiff_t nargs, Lisp_Object *args)
  3492 {
  3493   if (nargs == 0)
  3494     return make_fixnum (0);
  3495   Lisp_Object a = check_integer_coerce_marker (args[0]);
  3496   return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a);
  3497 }
  3498 
  3499 DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0,
  3500        doc: /* Return population count of VALUE.
  3501 This is the number of one bits in the two's complement representation
  3502 of VALUE.  If VALUE is negative, return the number of zero bits in the
  3503 representation.  */)
  3504   (Lisp_Object value)
  3505 {
  3506   CHECK_INTEGER (value);
  3507 
  3508   if (BIGNUMP (value))
  3509     {
  3510       mpz_t const *nonneg = xbignum_val (value);
  3511       if (mpz_sgn (*nonneg) < 0)
  3512         {
  3513           mpz_com (mpz[0], *nonneg);
  3514           nonneg = &mpz[0];
  3515         }
  3516       return make_fixnum (mpz_popcount (*nonneg));
  3517     }
  3518 
  3519   eassume (FIXNUMP (value));
  3520   EMACS_INT v = XFIXNUM (value) < 0 ? -1 - XFIXNUM (value) : XFIXNUM (value);
  3521   return make_fixnum (EMACS_UINT_WIDTH <= UINT_WIDTH
  3522                       ? count_one_bits (v)
  3523                       : EMACS_UINT_WIDTH <= ULONG_WIDTH
  3524                       ? count_one_bits_l (v)
  3525                       : count_one_bits_ll (v));
  3526 }
  3527 
  3528 DEFUN ("ash", Fash, Sash, 2, 2, 0,
  3529        doc: /* Return integer VALUE with its bits shifted left by COUNT bit positions.
  3530 If COUNT is negative, shift VALUE to the right instead.
  3531 VALUE and COUNT must be integers.
  3532 Mathematically, the return value is VALUE multiplied by 2 to the
  3533 power of COUNT, rounded down.  If the result is non-zero, its sign
  3534 is the same as that of VALUE.
  3535 In terms of bits, when COUNT is positive, the function moves
  3536 the bits of VALUE to the left, adding zero bits on the right; when
  3537 COUNT is negative, it moves the bits of VALUE to the right,
  3538 discarding bits.  */)
  3539   (Lisp_Object value, Lisp_Object count)
  3540 {
  3541   CHECK_INTEGER (value);
  3542   CHECK_INTEGER (count);
  3543 
  3544   if (! FIXNUMP (count))
  3545     {
  3546       if (BASE_EQ (value, make_fixnum (0)))
  3547         return value;
  3548       if (mpz_sgn (*xbignum_val (count)) < 0)
  3549         {
  3550           EMACS_INT v = (FIXNUMP (value) ? XFIXNUM (value)
  3551                          : mpz_sgn (*xbignum_val (value)));
  3552           return make_fixnum (v < 0 ? -1 : 0);
  3553         }
  3554       overflow_error ();
  3555     }
  3556 
  3557   if (XFIXNUM (count) <= 0)
  3558     {
  3559       if (XFIXNUM (count) == 0)
  3560         return value;
  3561 
  3562       if ((EMACS_INT) -1 >> 1 == -1 && FIXNUMP (value))
  3563         {
  3564           EMACS_INT shift = -XFIXNUM (count);
  3565           EMACS_INT result
  3566             = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift
  3567                : XFIXNUM (value) < 0 ? -1 : 0);
  3568           return make_fixnum (result);
  3569         }
  3570     }
  3571 
  3572   mpz_t const *zval = bignum_integer (&mpz[0], value);
  3573   if (XFIXNUM (count) < 0)
  3574     {
  3575       if (TYPE_MAXIMUM (mp_bitcnt_t) < - XFIXNUM (count))
  3576         return make_fixnum (mpz_sgn (*zval) < 0 ? -1 : 0);
  3577       mpz_fdiv_q_2exp (mpz[0], *zval, - XFIXNUM (count));
  3578     }
  3579   else
  3580     emacs_mpz_mul_2exp (mpz[0], *zval, XFIXNUM (count));
  3581   return make_integer_mpz ();
  3582 }
  3583 
  3584 /* Return X ** Y as an integer.  X and Y must be integers, and Y must
  3585    be nonnegative.  */
  3586 
  3587 Lisp_Object
  3588 expt_integer (Lisp_Object x, Lisp_Object y)
  3589 {
  3590   /* Special cases for -1 <= x <= 1, which never overflow.  */
  3591   if (BASE_EQ (x, make_fixnum (1)))
  3592     return x;
  3593   if (BASE_EQ (x, make_fixnum (0)))
  3594     return BASE_EQ (x, y) ? make_fixnum (1) : x;
  3595   if (BASE_EQ (x, make_fixnum (-1)))
  3596     return ((FIXNUMP (y) ? XFIXNUM (y) & 1 : mpz_odd_p (*xbignum_val (y)))
  3597             ? x : make_fixnum (1));
  3598 
  3599   unsigned long exp;
  3600   if (FIXNUMP (y))
  3601     {
  3602       if (ULONG_MAX < XFIXNUM (y))
  3603         overflow_error ();
  3604       exp = XFIXNUM (y);
  3605     }
  3606   else
  3607     {
  3608       if (ULONG_MAX <= MOST_POSITIVE_FIXNUM
  3609           || !mpz_fits_ulong_p (*xbignum_val (y)))
  3610         overflow_error ();
  3611       exp = mpz_get_ui (*xbignum_val (y));
  3612     }
  3613 
  3614   emacs_mpz_pow_ui (mpz[0], *bignum_integer (&mpz[0], x), exp);
  3615   return make_integer_mpz ();
  3616 }
  3617 
  3618 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
  3619        doc: /* Return NUMBER plus one.  NUMBER may be a number or a marker.
  3620 Markers are converted to integers.  */)
  3621   (Lisp_Object number)
  3622 {
  3623   number = check_number_coerce_marker (number);
  3624 
  3625   if (FIXNUMP (number))
  3626     return make_int (XFIXNUM (number) + 1);
  3627   if (FLOATP (number))
  3628     return (make_float (1.0 + XFLOAT_DATA (number)));
  3629   mpz_add_ui (mpz[0], *xbignum_val (number), 1);
  3630   return make_integer_mpz ();
  3631 }
  3632 
  3633 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
  3634        doc: /* Return NUMBER minus one.  NUMBER may be a number or a marker.
  3635 Markers are converted to integers.  */)
  3636   (Lisp_Object number)
  3637 {
  3638   number = check_number_coerce_marker (number);
  3639 
  3640   if (FIXNUMP (number))
  3641     return make_int (XFIXNUM (number) - 1);
  3642   if (FLOATP (number))
  3643     return (make_float (-1.0 + XFLOAT_DATA (number)));
  3644   mpz_sub_ui (mpz[0], *xbignum_val (number), 1);
  3645   return make_integer_mpz ();
  3646 }
  3647 
  3648 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
  3649        doc: /* Return the bitwise complement of NUMBER.  NUMBER must be an integer.  */)
  3650   (register Lisp_Object number)
  3651 {
  3652   CHECK_INTEGER (number);
  3653   if (FIXNUMP (number))
  3654     return make_fixnum (~XFIXNUM (number));
  3655   mpz_com (mpz[0], *xbignum_val (number));
  3656   return make_integer_mpz ();
  3657 }
  3658 
  3659 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
  3660        doc: /* Return the byteorder for the machine.
  3661 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
  3662 lowercase l) for small endian machines.  */
  3663        attributes: const)
  3664   (void)
  3665 {
  3666   unsigned i = 0x04030201;
  3667   int order = *(char *)&i == 1 ? 108 : 66;
  3668 
  3669   return make_fixnum (order);
  3670 }
  3671 
  3672 /* Because we round up the bool vector allocate size to word_size
  3673    units, we can safely read past the "end" of the vector in the
  3674    operations below.  These extra bits are always zero.  */
  3675 
  3676 static bits_word
  3677 bool_vector_spare_mask (EMACS_INT nr_bits)
  3678 {
  3679   return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1;
  3680 }
  3681 
  3682 /* Shift VAL right by the width of an unsigned long long.
  3683    ULLONG_WIDTH must be less than BITS_PER_BITS_WORD.  */
  3684 
  3685 static bits_word
  3686 shift_right_ull (bits_word w)
  3687 {
  3688   /* Pacify bogus GCC warning about shift count exceeding type width.  */
  3689   int shift = ULLONG_WIDTH - BITS_PER_BITS_WORD < 0 ? ULLONG_WIDTH : 0;
  3690   return w >> shift;
  3691 }
  3692 
  3693 /* Return the number of 1 bits in W.  */
  3694 
  3695 static int
  3696 count_one_bits_word (bits_word w)
  3697 {
  3698   if (BITS_WORD_MAX <= UINT_MAX)
  3699     return count_one_bits (w);
  3700   else if (BITS_WORD_MAX <= ULONG_MAX)
  3701     return count_one_bits_l (w);
  3702   else
  3703     {
  3704       int i = 0, count = 0;
  3705       while (count += count_one_bits_ll (w),
  3706              (i += ULLONG_WIDTH) < BITS_PER_BITS_WORD)
  3707         w = shift_right_ull (w);
  3708       return count;
  3709     }
  3710 }
  3711 
  3712 enum bool_vector_op { bool_vector_exclusive_or,
  3713                       bool_vector_union,
  3714                       bool_vector_intersection,
  3715                       bool_vector_set_difference,
  3716                       bool_vector_subsetp };
  3717 
  3718 static Lisp_Object
  3719 bool_vector_binop_driver (Lisp_Object a,
  3720                           Lisp_Object b,
  3721                           Lisp_Object dest,
  3722                           enum bool_vector_op op)
  3723 {
  3724   EMACS_INT nr_bits;
  3725   bits_word *adata, *bdata, *destdata;
  3726   ptrdiff_t i = 0;
  3727   ptrdiff_t nr_words;
  3728 
  3729   CHECK_BOOL_VECTOR (a);
  3730   CHECK_BOOL_VECTOR (b);
  3731 
  3732   nr_bits = bool_vector_size (a);
  3733   if (bool_vector_size (b) != nr_bits)
  3734     wrong_length_argument (a, b, dest);
  3735 
  3736   nr_words = bool_vector_words (nr_bits);
  3737   adata = bool_vector_data (a);
  3738   bdata = bool_vector_data (b);
  3739 
  3740   if (NILP (dest))
  3741     {
  3742       dest = make_uninit_bool_vector (nr_bits);
  3743       destdata = bool_vector_data (dest);
  3744     }
  3745   else
  3746     {
  3747       CHECK_BOOL_VECTOR (dest);
  3748       destdata = bool_vector_data (dest);
  3749       if (bool_vector_size (dest) != nr_bits)
  3750         wrong_length_argument (a, b, dest);
  3751 
  3752       switch (op)
  3753         {
  3754         case bool_vector_exclusive_or:
  3755           for (; i < nr_words; i++)
  3756             if (destdata[i] != (adata[i] ^ bdata[i]))
  3757               goto set_dest;
  3758           break;
  3759 
  3760         case bool_vector_subsetp:
  3761           for (; i < nr_words; i++)
  3762             if (adata[i] &~ bdata[i])
  3763               return Qnil;
  3764           return Qt;
  3765 
  3766         case bool_vector_union:
  3767           for (; i < nr_words; i++)
  3768             if (destdata[i] != (adata[i] | bdata[i]))
  3769               goto set_dest;
  3770           break;
  3771 
  3772         case bool_vector_intersection:
  3773           for (; i < nr_words; i++)
  3774             if (destdata[i] != (adata[i] & bdata[i]))
  3775               goto set_dest;
  3776           break;
  3777 
  3778         case bool_vector_set_difference:
  3779           for (; i < nr_words; i++)
  3780             if (destdata[i] != (adata[i] &~ bdata[i]))
  3781               goto set_dest;
  3782           break;
  3783         }
  3784 
  3785       return Qnil;
  3786     }
  3787 
  3788  set_dest:
  3789   switch (op)
  3790     {
  3791     case bool_vector_exclusive_or:
  3792       for (; i < nr_words; i++)
  3793         destdata[i] = adata[i] ^ bdata[i];
  3794       break;
  3795 
  3796     case bool_vector_union:
  3797       for (; i < nr_words; i++)
  3798         destdata[i] = adata[i] | bdata[i];
  3799       break;
  3800 
  3801     case bool_vector_intersection:
  3802       for (; i < nr_words; i++)
  3803         destdata[i] = adata[i] & bdata[i];
  3804       break;
  3805 
  3806     case bool_vector_set_difference:
  3807       for (; i < nr_words; i++)
  3808         destdata[i] = adata[i] &~ bdata[i];
  3809       break;
  3810 
  3811     default:
  3812       eassume (0);
  3813     }
  3814 
  3815   return dest;
  3816 }
  3817 
  3818 /* PRECONDITION must be true.  Return VALUE.  This odd construction
  3819    works around a bogus GCC diagnostic "shift count >= width of type".  */
  3820 
  3821 static int
  3822 pre_value (bool precondition, int value)
  3823 {
  3824   eassume (precondition);
  3825   return precondition ? value : 0;
  3826 }
  3827 
  3828 /* Compute the number of trailing zero bits in val.  If val is zero,
  3829    return the number of bits in val.  */
  3830 static int
  3831 count_trailing_zero_bits (bits_word val)
  3832 {
  3833   if (BITS_WORD_MAX == UINT_MAX)
  3834     return count_trailing_zeros (val);
  3835   if (BITS_WORD_MAX == ULONG_MAX)
  3836     return count_trailing_zeros_l (val);
  3837   if (BITS_WORD_MAX == ULLONG_MAX)
  3838     return count_trailing_zeros_ll (val);
  3839 
  3840   /* The rest of this code is for the unlikely platform where bits_word differs
  3841      in width from unsigned int, unsigned long, and unsigned long long.  */
  3842   val |= ~ BITS_WORD_MAX;
  3843   if (BITS_WORD_MAX <= UINT_MAX)
  3844     return count_trailing_zeros (val);
  3845   if (BITS_WORD_MAX <= ULONG_MAX)
  3846     return count_trailing_zeros_l (val);
  3847   else
  3848     {
  3849       int count;
  3850       for (count = 0;
  3851            count < BITS_PER_BITS_WORD - ULLONG_WIDTH;
  3852            count += ULLONG_WIDTH)
  3853         {
  3854           if (val & ULLONG_MAX)
  3855             return count + count_trailing_zeros_ll (val);
  3856           val = shift_right_ull (val);
  3857         }
  3858 
  3859       if (BITS_PER_BITS_WORD % ULLONG_WIDTH != 0
  3860           && BITS_WORD_MAX == (bits_word) -1)
  3861         val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX,
  3862                                            BITS_PER_BITS_WORD % ULLONG_WIDTH);
  3863       return count + count_trailing_zeros_ll (val);
  3864     }
  3865 }
  3866 
  3867 static bits_word
  3868 bits_word_to_host_endian (bits_word val)
  3869 {
  3870 #ifndef WORDS_BIGENDIAN
  3871   return val;
  3872 #else
  3873   if (BITS_WORD_MAX >> 31 == 1)
  3874     return bswap_32 (val);
  3875   if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
  3876     return bswap_64 (val);
  3877   {
  3878     int i;
  3879     bits_word r = 0;
  3880     for (i = 0; i < sizeof val; i++)
  3881       {
  3882         r = ((r << 1 << (CHAR_BIT - 1))
  3883              | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
  3884         val = val >> 1 >> (CHAR_BIT - 1);
  3885       }
  3886     return r;
  3887   }
  3888 #endif
  3889 }
  3890 
  3891 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
  3892        Sbool_vector_exclusive_or, 2, 3, 0,
  3893        doc: /* Return A ^ B, bitwise exclusive or.
  3894 If optional third argument C is given, store result into C.
  3895 A, B, and C must be bool vectors of the same length.
  3896 Return the destination vector if it changed or nil otherwise.  */)
  3897   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3898 {
  3899   return bool_vector_binop_driver (a, b, c, bool_vector_exclusive_or);
  3900 }
  3901 
  3902 DEFUN ("bool-vector-union", Fbool_vector_union,
  3903        Sbool_vector_union, 2, 3, 0,
  3904        doc: /* Return A | B, bitwise or.
  3905 If optional third argument C is given, store result into C.
  3906 A, B, and C must be bool vectors of the same length.
  3907 Return the destination vector if it changed or nil otherwise.  */)
  3908   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3909 {
  3910   return bool_vector_binop_driver (a, b, c, bool_vector_union);
  3911 }
  3912 
  3913 DEFUN ("bool-vector-intersection", Fbool_vector_intersection,
  3914        Sbool_vector_intersection, 2, 3, 0,
  3915        doc: /* Return A & B, bitwise and.
  3916 If optional third argument C is given, store result into C.
  3917 A, B, and C must be bool vectors of the same length.
  3918 Return the destination vector if it changed or nil otherwise.  */)
  3919   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3920 {
  3921   return bool_vector_binop_driver (a, b, c, bool_vector_intersection);
  3922 }
  3923 
  3924 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference,
  3925        Sbool_vector_set_difference, 2, 3, 0,
  3926        doc: /* Return A &~ B, set difference.
  3927 If optional third argument C is given, store result into C.
  3928 A, B, and C must be bool vectors of the same length.
  3929 Return the destination vector if it changed or nil otherwise.  */)
  3930   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3931 {
  3932   return bool_vector_binop_driver (a, b, c, bool_vector_set_difference);
  3933 }
  3934 
  3935 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp,
  3936        Sbool_vector_subsetp, 2, 2, 0,
  3937        doc: /* Return t if every t value in A is also t in B, nil otherwise.
  3938 A and B must be bool vectors of the same length.  */)
  3939   (Lisp_Object a, Lisp_Object b)
  3940 {
  3941   return bool_vector_binop_driver (a, b, b, bool_vector_subsetp);
  3942 }
  3943 
  3944 DEFUN ("bool-vector-not", Fbool_vector_not,
  3945        Sbool_vector_not, 1, 2, 0,
  3946        doc: /* Compute ~A, set complement.
  3947 If optional second argument B is given, store result into B.
  3948 A and B must be bool vectors of the same length.
  3949 Return the destination vector.  */)
  3950   (Lisp_Object a, Lisp_Object b)
  3951 {
  3952   EMACS_INT nr_bits;
  3953   bits_word *bdata, *adata;
  3954   ptrdiff_t i;
  3955 
  3956   CHECK_BOOL_VECTOR (a);
  3957   nr_bits = bool_vector_size (a);
  3958 
  3959   if (NILP (b))
  3960     b = make_uninit_bool_vector (nr_bits);
  3961   else
  3962     {
  3963       CHECK_BOOL_VECTOR (b);
  3964       if (bool_vector_size (b) != nr_bits)
  3965         wrong_length_argument (a, b, Qnil);
  3966     }
  3967 
  3968   bdata = bool_vector_data (b);
  3969   adata = bool_vector_data (a);
  3970 
  3971   for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++)
  3972     bdata[i] = BITS_WORD_MAX & ~adata[i];
  3973 
  3974   if (nr_bits % BITS_PER_BITS_WORD)
  3975     {
  3976       bits_word mword = bits_word_to_host_endian (adata[i]);
  3977       mword = ~mword;
  3978       mword &= bool_vector_spare_mask (nr_bits);
  3979       bdata[i] = bits_word_to_host_endian (mword);
  3980     }
  3981 
  3982   return b;
  3983 }
  3984 
  3985 DEFUN ("bool-vector-count-population", Fbool_vector_count_population,
  3986        Sbool_vector_count_population, 1, 1, 0,
  3987        doc: /* Count how many elements in A are t.
  3988 A is a bool vector.  To count A's nil elements, subtract the return
  3989 value from A's length.  */)
  3990   (Lisp_Object a)
  3991 {
  3992   EMACS_INT count;
  3993   EMACS_INT nr_bits;
  3994   bits_word *adata;
  3995   ptrdiff_t i, nwords;
  3996 
  3997   CHECK_BOOL_VECTOR (a);
  3998 
  3999   nr_bits = bool_vector_size (a);
  4000   nwords = bool_vector_words (nr_bits);
  4001   count = 0;
  4002   adata = bool_vector_data (a);
  4003 
  4004   for (i = 0; i < nwords; i++)
  4005     count += count_one_bits_word (adata[i]);
  4006 
  4007   return make_fixnum (count);
  4008 }
  4009 
  4010 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive,
  4011        Sbool_vector_count_consecutive, 3, 3, 0,
  4012        doc: /* Count how many consecutive elements in A equal B starting at I.
  4013 A is a bool vector, B is t or nil, and I is an index into A.  */)
  4014   (Lisp_Object a, Lisp_Object b, Lisp_Object i)
  4015 {
  4016   EMACS_INT count;
  4017   EMACS_INT nr_bits;
  4018   int offset;
  4019   bits_word *adata;
  4020   bits_word twiddle;
  4021   bits_word mword; /* Machine word.  */
  4022   ptrdiff_t pos, pos0;
  4023   ptrdiff_t nr_words;
  4024 
  4025   CHECK_BOOL_VECTOR (a);
  4026   CHECK_FIXNAT (i);
  4027 
  4028   nr_bits = bool_vector_size (a);
  4029   if (XFIXNAT (i) > nr_bits) /* Allow one past the end for convenience */
  4030     args_out_of_range (a, i);
  4031 
  4032   adata = bool_vector_data (a);
  4033   nr_words = bool_vector_words (nr_bits);
  4034   pos = XFIXNAT (i) / BITS_PER_BITS_WORD;
  4035   offset = XFIXNAT (i) % BITS_PER_BITS_WORD;
  4036   count = 0;
  4037 
  4038   /* By XORing with twiddle, we transform the problem of "count
  4039      consecutive equal values" into "count the zero bits".  The latter
  4040      operation usually has hardware support.  */
  4041   twiddle = NILP (b) ? 0 : BITS_WORD_MAX;
  4042 
  4043   /* Scan the remainder of the mword at the current offset.  */
  4044   if (pos < nr_words && offset != 0)
  4045     {
  4046       mword = bits_word_to_host_endian (adata[pos]);
  4047       mword ^= twiddle;
  4048       mword >>= offset;
  4049 
  4050       /* Do not count the pad bits.  */
  4051       mword |= (bits_word) 1 << (BITS_PER_BITS_WORD - offset);
  4052 
  4053       count = count_trailing_zero_bits (mword);
  4054       pos++;
  4055       if (count + offset < BITS_PER_BITS_WORD)
  4056         return make_fixnum (count);
  4057     }
  4058 
  4059   /* Scan whole words until we either reach the end of the vector or
  4060      find an mword that doesn't completely match.  twiddle is
  4061      endian-independent.  */
  4062   pos0 = pos;
  4063   while (pos < nr_words && adata[pos] == twiddle)
  4064     pos++;
  4065   count += (pos - pos0) * BITS_PER_BITS_WORD;
  4066 
  4067   if (pos < nr_words)
  4068     {
  4069       /* If we stopped because of a mismatch, see how many bits match
  4070          in the current mword.  */
  4071       mword = bits_word_to_host_endian (adata[pos]);
  4072       mword ^= twiddle;
  4073       count += count_trailing_zero_bits (mword);
  4074     }
  4075   else if (nr_bits % BITS_PER_BITS_WORD != 0)
  4076     {
  4077       /* If we hit the end, we might have overshot our count.  Reduce
  4078          the total by the number of spare bits at the end of the
  4079          vector.  */
  4080       count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
  4081     }
  4082 
  4083   return make_fixnum (count);
  4084 }
  4085 
  4086 
  4087 void
  4088 syms_of_data (void)
  4089 {
  4090   Lisp_Object error_tail, arith_tail, recursion_tail;
  4091 
  4092   DEFSYM (Qquote, "quote");
  4093   DEFSYM (Qlambda, "lambda");
  4094   DEFSYM (Qerror_conditions, "error-conditions");
  4095   DEFSYM (Qerror_message, "error-message");
  4096   DEFSYM (Qtop_level, "top-level");
  4097 
  4098   DEFSYM (Qerror, "error");
  4099   DEFSYM (Quser_error, "user-error");
  4100   DEFSYM (Qquit, "quit");
  4101   DEFSYM (Qminibuffer_quit, "minibuffer-quit");
  4102   DEFSYM (Qwrong_length_argument, "wrong-length-argument");
  4103   DEFSYM (Qwrong_type_argument, "wrong-type-argument");
  4104   DEFSYM (Qargs_out_of_range, "args-out-of-range");
  4105   DEFSYM (Qvoid_function, "void-function");
  4106   DEFSYM (Qcyclic_function_indirection, "cyclic-function-indirection");
  4107   DEFSYM (Qcyclic_variable_indirection, "cyclic-variable-indirection");
  4108   DEFSYM (Qvoid_variable, "void-variable");
  4109   DEFSYM (Qsetting_constant, "setting-constant");
  4110   DEFSYM (Qtrapping_constant, "trapping-constant");
  4111   DEFSYM (Qinvalid_read_syntax, "invalid-read-syntax");
  4112 
  4113   DEFSYM (Qinvalid_function, "invalid-function");
  4114   DEFSYM (Qwrong_number_of_arguments, "wrong-number-of-arguments");
  4115   DEFSYM (Qno_catch, "no-catch");
  4116   DEFSYM (Qend_of_file, "end-of-file");
  4117   DEFSYM (Qarith_error, "arith-error");
  4118   DEFSYM (Qbeginning_of_buffer, "beginning-of-buffer");
  4119   DEFSYM (Qend_of_buffer, "end-of-buffer");
  4120   DEFSYM (Qbuffer_read_only, "buffer-read-only");
  4121   DEFSYM (Qtext_read_only, "text-read-only");
  4122   DEFSYM (Qmark_inactive, "mark-inactive");
  4123   DEFSYM (Qinhibited_interaction, "inhibited-interaction");
  4124 
  4125   DEFSYM (Qrecursion_error, "recursion-error");
  4126   DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding");
  4127   DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting");
  4128 
  4129   DEFSYM (Qlistp, "listp");
  4130   DEFSYM (Qconsp, "consp");
  4131   DEFSYM (Qbare_symbol_p, "bare-symbol-p");
  4132   DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
  4133   DEFSYM (Qsymbolp, "symbolp");
  4134   DEFSYM (Qfixnump, "fixnump");
  4135   DEFSYM (Qintegerp, "integerp");
  4136   DEFSYM (Qbooleanp, "booleanp");
  4137   DEFSYM (Qnatnump, "natnump");
  4138   DEFSYM (Qwholenump, "wholenump");
  4139   DEFSYM (Qstringp, "stringp");
  4140   DEFSYM (Qarrayp, "arrayp");
  4141   DEFSYM (Qsequencep, "sequencep");
  4142   DEFSYM (Qbufferp, "bufferp");
  4143   DEFSYM (Qvectorp, "vectorp");
  4144   DEFSYM (Qrecordp, "recordp");
  4145   DEFSYM (Qbool_vector_p, "bool-vector-p");
  4146   DEFSYM (Qchar_or_string_p, "char-or-string-p");
  4147   DEFSYM (Qmarkerp, "markerp");
  4148   DEFSYM (Quser_ptrp, "user-ptrp");
  4149   DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
  4150   DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p");
  4151   DEFSYM (Qfboundp, "fboundp");
  4152 
  4153   DEFSYM (Qfloatp, "floatp");
  4154   DEFSYM (Qnumberp, "numberp");
  4155   DEFSYM (Qnumber_or_marker_p, "number-or-marker-p");
  4156 
  4157   DEFSYM (Qchar_table_p, "char-table-p");
  4158   DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
  4159   DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p");
  4160   DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form");
  4161 
  4162   DEFSYM (Qsubrp, "subrp");
  4163   DEFSYM (Qunevalled, "unevalled");
  4164   DEFSYM (Qmany, "many");
  4165 
  4166   DEFSYM (Qcdr, "cdr");
  4167 
  4168   error_tail = pure_cons (Qerror, Qnil);
  4169 
  4170   /* ERROR is used as a signaler for random errors for which nothing else is
  4171      right.  */
  4172 
  4173   Fput (Qerror, Qerror_conditions,
  4174         error_tail);
  4175   Fput (Qerror, Qerror_message,
  4176         build_pure_c_string ("error"));
  4177 
  4178 #define PUT_ERROR(sym, tail, msg)                       \
  4179   Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
  4180   Fput (sym, Qerror_message, build_pure_c_string (msg))
  4181 
  4182   PUT_ERROR (Qquit, Qnil, "Quit");
  4183   PUT_ERROR (Qminibuffer_quit, pure_cons (Qquit, Qnil), "Quit");
  4184 
  4185   PUT_ERROR (Quser_error, error_tail, "");
  4186   PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
  4187   PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
  4188   PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
  4189   PUT_ERROR (Qvoid_function, error_tail,
  4190              "Symbol's function definition is void");
  4191   PUT_ERROR (Qcyclic_function_indirection, error_tail,
  4192              "Symbol's chain of function indirections contains a loop");
  4193   PUT_ERROR (Qcyclic_variable_indirection, error_tail,
  4194              "Symbol's chain of variable indirections contains a loop");
  4195   DEFSYM (Qcircular_list, "circular-list");
  4196   PUT_ERROR (Qcircular_list, error_tail, "List contains a loop");
  4197   PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void");
  4198   PUT_ERROR (Qsetting_constant, error_tail,
  4199              "Attempt to set a constant symbol");
  4200   PUT_ERROR (Qtrapping_constant, error_tail,
  4201              "Attempt to trap writes to a constant symbol");
  4202   PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax");
  4203   PUT_ERROR (Qinvalid_function, error_tail, "Invalid function");
  4204   PUT_ERROR (Qwrong_number_of_arguments, error_tail,
  4205              "Wrong number of arguments");
  4206   PUT_ERROR (Qno_catch, error_tail, "No catch for tag");
  4207   PUT_ERROR (Qend_of_file, error_tail, "End of file during parsing");
  4208 
  4209   arith_tail = pure_cons (Qarith_error, error_tail);
  4210   Fput (Qarith_error, Qerror_conditions, arith_tail);
  4211   Fput (Qarith_error, Qerror_message, build_pure_c_string ("Arithmetic error"));
  4212 
  4213   PUT_ERROR (Qbeginning_of_buffer, error_tail, "Beginning of buffer");
  4214   PUT_ERROR (Qend_of_buffer, error_tail, "End of buffer");
  4215   PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only");
  4216   PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail),
  4217              "Text is read-only");
  4218   PUT_ERROR (Qinhibited_interaction, error_tail,
  4219              "User interaction while inhibited");
  4220 
  4221   DEFSYM (Qrange_error, "range-error");
  4222   DEFSYM (Qdomain_error, "domain-error");
  4223   DEFSYM (Qsingularity_error, "singularity-error");
  4224   DEFSYM (Qoverflow_error, "overflow-error");
  4225   DEFSYM (Qunderflow_error, "underflow-error");
  4226 
  4227   PUT_ERROR (Qdomain_error, arith_tail, "Arithmetic domain error");
  4228 
  4229   PUT_ERROR (Qrange_error, arith_tail, "Arithmetic range error");
  4230 
  4231   PUT_ERROR (Qsingularity_error, Fcons (Qdomain_error, arith_tail),
  4232              "Arithmetic singularity error");
  4233 
  4234   PUT_ERROR (Qoverflow_error, Fcons (Qrange_error, arith_tail),
  4235              "Arithmetic overflow error");
  4236   PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail),
  4237              "Arithmetic underflow error");
  4238 
  4239   recursion_tail = pure_cons (Qrecursion_error, error_tail);
  4240   Fput (Qrecursion_error, Qerror_conditions, recursion_tail);
  4241   Fput (Qrecursion_error, Qerror_message, build_pure_c_string
  4242         ("Excessive recursive calling error"));
  4243 
  4244   PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
  4245              "Variable binding depth exceeds max-specpdl-size");
  4246   PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
  4247              "Lisp nesting exceeds `max-lisp-eval-depth'");
  4248 
  4249   /* Types that type-of returns.  */
  4250   DEFSYM (Qinteger, "integer");
  4251   DEFSYM (Qsymbol, "symbol");
  4252   DEFSYM (Qstring, "string");
  4253   DEFSYM (Qcons, "cons");
  4254   DEFSYM (Qmarker, "marker");
  4255   DEFSYM (Qsymbol_with_pos, "symbol-with-pos");
  4256   DEFSYM (Qoverlay, "overlay");
  4257   DEFSYM (Qfinalizer, "finalizer");
  4258   DEFSYM (Qmodule_function, "module-function");
  4259   DEFSYM (Qnative_comp_unit, "native-comp-unit");
  4260   DEFSYM (Quser_ptr, "user-ptr");
  4261   DEFSYM (Qfloat, "float");
  4262   DEFSYM (Qwindow_configuration, "window-configuration");
  4263   DEFSYM (Qprocess, "process");
  4264   DEFSYM (Qwindow, "window");
  4265   DEFSYM (Qsubr, "subr");
  4266   DEFSYM (Qcompiled_function, "compiled-function");
  4267   DEFSYM (Qbuffer, "buffer");
  4268   DEFSYM (Qframe, "frame");
  4269   DEFSYM (Qvector, "vector");
  4270   DEFSYM (Qrecord, "record");
  4271   DEFSYM (Qchar_table, "char-table");
  4272   DEFSYM (Qbool_vector, "bool-vector");
  4273   DEFSYM (Qhash_table, "hash-table");
  4274   DEFSYM (Qthread, "thread");
  4275   DEFSYM (Qmutex, "mutex");
  4276   DEFSYM (Qcondition_variable, "condition-variable");
  4277   DEFSYM (Qfont_spec, "font-spec");
  4278   DEFSYM (Qfont_entity, "font-entity");
  4279   DEFSYM (Qfont_object, "font-object");
  4280   DEFSYM (Qterminal, "terminal");
  4281   DEFSYM (Qxwidget, "xwidget");
  4282   DEFSYM (Qxwidget_view, "xwidget-view");
  4283   DEFSYM (Qtreesit_parser, "treesit-parser");
  4284   DEFSYM (Qtreesit_node, "treesit-node");
  4285   DEFSYM (Qtreesit_compiled_query, "treesit-compiled-query");
  4286 
  4287   DEFSYM (Qdefun, "defun");
  4288 
  4289   DEFSYM (Qinteractive_form, "interactive-form");
  4290   DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
  4291   DEFSYM (Qfunction_history, "function-history");
  4292 
  4293   DEFSYM (Qbyte_code_function_p, "byte-code-function-p");
  4294 
  4295   defsubr (&Sindirect_variable);
  4296   defsubr (&Sinteractive_form);
  4297   defsubr (&Scommand_modes);
  4298   defsubr (&Seq);
  4299   defsubr (&Snull);
  4300   defsubr (&Stype_of);
  4301   defsubr (&Slistp);
  4302   defsubr (&Snlistp);
  4303   defsubr (&Sconsp);
  4304   defsubr (&Satom);
  4305   defsubr (&Sintegerp);
  4306   defsubr (&Sinteger_or_marker_p);
  4307   defsubr (&Snumberp);
  4308   defsubr (&Snumber_or_marker_p);
  4309   defsubr (&Sfloatp);
  4310   defsubr (&Snatnump);
  4311   defsubr (&Sbare_symbol_p);
  4312   defsubr (&Ssymbol_with_pos_p);
  4313   defsubr (&Ssymbolp);
  4314   defsubr (&Skeywordp);
  4315   defsubr (&Sstringp);
  4316   defsubr (&Smultibyte_string_p);
  4317   defsubr (&Svectorp);
  4318   defsubr (&Srecordp);
  4319   defsubr (&Schar_table_p);
  4320   defsubr (&Svector_or_char_table_p);
  4321   defsubr (&Sbool_vector_p);
  4322   defsubr (&Sarrayp);
  4323   defsubr (&Ssequencep);
  4324   defsubr (&Sbufferp);
  4325   defsubr (&Smarkerp);
  4326   defsubr (&Ssubrp);
  4327   defsubr (&Sbyte_code_function_p);
  4328   defsubr (&Smodule_function_p);
  4329   defsubr (&Schar_or_string_p);
  4330   defsubr (&Sthreadp);
  4331   defsubr (&Smutexp);
  4332   defsubr (&Scondition_variable_p);
  4333   defsubr (&Scar);
  4334   defsubr (&Scdr);
  4335   defsubr (&Scar_safe);
  4336   defsubr (&Scdr_safe);
  4337   defsubr (&Ssetcar);
  4338   defsubr (&Ssetcdr);
  4339   defsubr (&Ssymbol_function);
  4340   defsubr (&Sindirect_function);
  4341   defsubr (&Ssymbol_plist);
  4342   defsubr (&Ssymbol_name);
  4343   defsubr (&Sbare_symbol);
  4344   defsubr (&Ssymbol_with_pos_pos);
  4345   defsubr (&Sremove_pos_from_symbol);
  4346   defsubr (&Sposition_symbol);
  4347   defsubr (&Smakunbound);
  4348   defsubr (&Sfmakunbound);
  4349   defsubr (&Sboundp);
  4350   defsubr (&Sfboundp);
  4351   defsubr (&Sfset);
  4352   defsubr (&Sdefalias);
  4353   defsubr (&Ssetplist);
  4354   defsubr (&Ssymbol_value);
  4355   defsubr (&Sset);
  4356   defsubr (&Sdefault_boundp);
  4357   defsubr (&Sdefault_value);
  4358   defsubr (&Sset_default);
  4359   defsubr (&Smake_variable_buffer_local);
  4360   defsubr (&Smake_local_variable);
  4361   defsubr (&Skill_local_variable);
  4362   defsubr (&Slocal_variable_p);
  4363   defsubr (&Slocal_variable_if_set_p);
  4364   defsubr (&Svariable_binding_locus);
  4365   defsubr (&Saref);
  4366   defsubr (&Saset);
  4367   defsubr (&Snumber_to_string);
  4368   defsubr (&Sstring_to_number);
  4369   defsubr (&Seqlsign);
  4370   defsubr (&Slss);
  4371   defsubr (&Sgtr);
  4372   defsubr (&Sleq);
  4373   defsubr (&Sgeq);
  4374   defsubr (&Sneq);
  4375   defsubr (&Splus);
  4376   defsubr (&Sminus);
  4377   defsubr (&Stimes);
  4378   defsubr (&Squo);
  4379   defsubr (&Srem);
  4380   defsubr (&Smod);
  4381   defsubr (&Smax);
  4382   defsubr (&Smin);
  4383   defsubr (&Slogand);
  4384   defsubr (&Slogior);
  4385   defsubr (&Slogxor);
  4386   defsubr (&Slogcount);
  4387   defsubr (&Sash);
  4388   defsubr (&Sadd1);
  4389   defsubr (&Ssub1);
  4390   defsubr (&Slognot);
  4391   defsubr (&Sbyteorder);
  4392   defsubr (&Ssubr_arity);
  4393   defsubr (&Ssubr_name);
  4394   defsubr (&Ssubr_native_elisp_p);
  4395   defsubr (&Ssubr_native_lambda_list);
  4396   defsubr (&Ssubr_type);
  4397 #ifdef HAVE_NATIVE_COMP
  4398   defsubr (&Ssubr_native_comp_unit);
  4399   defsubr (&Snative_comp_unit_file);
  4400   defsubr (&Snative_comp_unit_set_file);
  4401 #endif
  4402 #ifdef HAVE_MODULES
  4403   defsubr (&Suser_ptrp);
  4404 #endif
  4405 
  4406   defsubr (&Sbool_vector_exclusive_or);
  4407   defsubr (&Sbool_vector_union);
  4408   defsubr (&Sbool_vector_intersection);
  4409   defsubr (&Sbool_vector_set_difference);
  4410   defsubr (&Sbool_vector_not);
  4411   defsubr (&Sbool_vector_subsetp);
  4412   defsubr (&Sbool_vector_count_consecutive);
  4413   defsubr (&Sbool_vector_count_population);
  4414 
  4415   set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->u.s.function);
  4416 
  4417   DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
  4418                doc: /* The greatest integer that is represented efficiently.
  4419 This variable cannot be set; trying to do so will signal an error.  */);
  4420   Vmost_positive_fixnum = make_fixnum (MOST_POSITIVE_FIXNUM);
  4421   make_symbol_constant (intern_c_string ("most-positive-fixnum"));
  4422 
  4423   DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum,
  4424                doc: /* The least integer that is represented efficiently.
  4425 This variable cannot be set; trying to do so will signal an error.  */);
  4426   Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM);
  4427   make_symbol_constant (intern_c_string ("most-negative-fixnum"));
  4428 
  4429   DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled");
  4430   DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled,
  4431                doc: /* Non-nil when "symbols with position" can be used as symbols.
  4432 Bind this to non-nil in applications such as the byte compiler.  */);
  4433   symbols_with_pos_enabled = false;
  4434 
  4435   DEFSYM (Qwatchers, "watchers");
  4436   DEFSYM (Qmakunbound, "makunbound");
  4437   DEFSYM (Qunlet, "unlet");
  4438   DEFSYM (Qset, "set");
  4439   DEFSYM (Qset_default, "set-default");
  4440   DEFSYM (Qcommand_modes, "command-modes");
  4441   defsubr (&Sadd_variable_watcher);
  4442   defsubr (&Sremove_variable_watcher);
  4443   defsubr (&Sget_variable_watchers);
  4444 }